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forwarding,  use  of  register  variables,  as  well  as  various  MDP-specific  optimizations  in  the 
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The  MDP  presents  some  unique  challenges  and  opportunities  for  compilation.  Due  to  the 
MDFs  small  memory  size,  it  is  critical  that  the  size  of  the  generated  code  be  as  small  as 
possible.  The  MDP  is  an  inherently  concurrent  processor  with  efficient  mechanisms  for 
sending  and  receiving  messages;  the  compiler  takes  advantage  of  these  mechanisms.  The 
MDFs  tagged  architecture  allows  very  efficient  support  of  object-oriented  languages  such  as 
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Chapter  1.  Introduction 

The  Optimist  is  an  optimizing  compiler  for  the  Concurrent  Smalltalk  language.  Concurrent 
Smalltalk  is  a  concurrent  version  of  Smalltalk  developed  by  the  Concurrent  VLSI 
Architecture  Group.  The  compiler  compiles  Concurrent  Smalltalk  to  the  assembly  language 
of  the  Message-Driven  Processor  (MDP). 

The  Optimist  includes  some  standard  optimizations  such  as  register  variable  assignment, 
dataflow  analysis,  copy  propagation,  and  dead  code  elimination  [2]  [13]  that  are  used  in 
compilers  for  conventional  processors.  However,  due  to  its  fine-grained  parallel  nature, 
compiling  for  the  MDP  is  unlike  compiling  for  most  conventional  processors  in  a  few 
important  aspects  which  will  become  apparent  in  the  later  chapters.  For  instance,  loops  are 
not  important  on  the  MDP,  while  minimizing  code  size,  tail  forwarding  methods,  and 
efficiently  and  seamlessly  handling  parallelism  are  extremely  important. 

Several  new  optimizations  or  variants  of  optimizations  were  developed  for  the  Optimist.  For 
example,  the  Optimist  includes  Fork  and  Join  Mergers  that  try  to  merge  similar  (not 
necessarily  identical)  statements  on  both  sides  of  conditionals;  often  the  Mergers  successfully 
merge  quite  different  statements,  producing  unusual  (but  nevertheless  helpful)  results.  The 
Optimist's  Move  Eliminator  is  more  powerful  than  standard  copy  propagation  schemes  such 
as  the  one  given  in  [2].  While  compiling,  the  Optimist  works  with  a  flow  of  control  graph  of 
statements  and  totally  forgets  the  original  order  of  statements  in  the  source  code,  so  it 
includes  a  Linearizer  that  tries  to  find  the  best  linear  order  for  the  statements  in  the  object 
code.  Also,  the  Optimist  includes  numerous  code  generator  optimizations  to  accomodate 
various  idiosyncrasies  of  the  MDP.  Finally,  several  unexpected  problems  arise  in  the  area  of 
synchronizing  processes  through  the  use  of  futures;  these  problems  and  their  solutions  are 
presented  in  Chapter  6. 

The  MDP  Project 

The  MDP  is  a  processing  node  for  the  J-Machine,  a  multiple  instruction/multiple  data 
concurrent  computer  [6],  The  J-Machine  will  be  composed  of  up  to  65536  MDPs.  The  nodes 
communicate  with  each  other  by  sending  messages  over  a  high-speed  network.  The  MDP 
nodes  are  optimized  to  minimize  message  sending  and  reception  overheads;  receiving  and 
dispatching  on  a  message  or  sending  one  should  take  only  a  few  clock  cycles,  permitting  effi¬ 
cient  execution  of  finely  grained  concurrent  programs.  The  project’s  goals  are  to  fabricate  the 
MDPs  in  VLSI,  build  a  computer  based  on  the  MDPs,  write  the  necessary  operating  system 
and  language  software,  and  analyze  the  performance  of  the  resulting  machine. 

Concurrent  Smalltalk 

Concurrent  Smalltalk  is  a  concurrent  version  of  the  object-oriented  programming  language 
Smalltalk.  It  introduces  concurrency  to  standard  Smalltalk  by  evaluating  arguments  to 
method  calls  in  parallel  as  well  as  allowing  the  computation  of  the  value  of  a  variable  to 
proceed  in  parallel  with  the  other  computations  of  the  method  until  the  variable's  value  is 
actually  needed.  The  cset  construct  (as  opposed  to  set)  is  used  to  assign  a  value  to  a 
variable  without  actually  requesting  that  the  value  be  computed  before  going  on  to  the  next 
statement.  For  example,  in  the  code  sequence 
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(cs«t  a  (long-computation  1 )) 

(cast  b  (time-sink  1)) 

(return  (+  a  b)) 

the  computation  of  a  proceeds  in  parallel  with  the  rest  of  the  method  until  the  value  of  a  is 
actually  needed  in  the  third  statement;  thus,  long-computation  and  time-sink  execute  in 
parallel. 

Please  refer  to  the  Chapter  2  for  more  details  on  the  Concurrent  Smalltalk  language. 

Why  Concurrent  Smalltalk? 

Concurrent  Smalltalk  is  an  ideal  language  for  programming  the  J-Machine  because  it  yields 
small  methods  and  locality  of  references.  The  methods  dealing  with  a  particular  class  travel 
to  the  data  object  as  opposed  to  the  data  traveling  to  the  code.  Concurrent  Smalltalk  provides 
excellent  facilities  for  creating  data  abstractions  and  “algorithm-independent 
programming"— once  an  algorithm  to  solve  a  problem  has  been  developed  for  the  J-Machine, 
application  programs  can  use  that  algorithm  as  a  library  routine;  furthermore,  when  an 
improvement  in  the  algorithm  is  made,  the  change  can  be  installed  without  rewriting 
application  code. 

Another  reason  for  using  Concurrent  Smalltalk  is  that  it  is  low-level  enough  to  be  useful  in 
implementing  the  J-Machine  operating  system,  while  being  at  a  high  enough  level  that  the 
programmer  does  not  have  to  worry  about  the  infamous  problems  of  parallel  process 
synchronization  and  deadlocks.  In  fact,  once  the  data  structures  are  defined  properly, 
programming  in  Concurrent  Smalltalk  feels  much  like  programming  in  a  standard  sequential 
language. 

The  Message-Driven  Processor 

The  MDP  is  a  processing  node  for  the  J-Machine.  Each  MDP  chip  contains  a  microprocessor, 
memory,  and  a  network  interface  for  communicating  with  neighboring  MDPs. 

The  microprocessor  has  a  register-based  architecture.  It  operates  on  32-bit  data  words  with 

4-bit  tags  that  identify  the  type  of  the  data.  Tags  are  essential  in  efficiently  supporting  an  I 

object-oriented  language  such  as  Concurrent  Smalltalk.  Data  types  of  variables  in 

Concurrent  Smalltalk  are  in  general  not  known  except  when  the  program  is  actually  running, 

so  the  compiler  does  not  know  whether  a  primitive  operation  such  as  +  will  receive  integers  or 

complex  data  structures  like  matrices  as  arguments.  By  implementing  tags  and  type 

checking  in  hardware,  the  compiled  code  can  just  invoke  the  add  instruction;  if  the 

arguments  are  not  tagged  as  integers,  the  MDP  will  fault  and  the  operating  system  will  make  I 

a  slower  method  call  to  add  the  matrices.  Another  reason  for  having  tags  is  that  they  allow 

implementation  of  garbage  collection  algorithms  that  otherwise  could  not  distinguish  an 

integer  from  a  pointer. 

The  MDP  is  message-based.  In  its  normal  mode  of  operation,  the  MDP  listens  on  the  network 

for  messages.  When  it  receives  a  message  addressed  to  it,  it  stores  the  message  in  the  input  j 

message  queue  and  dispatches  on  the  address  given  in  the  first  word  of  the  message. 

Messages  are  used  as  method  calls;  when  a  running  process  wants  to  call  a  method,  it  sends 

in  the  form  of  a  SEND  message  the  method  selector  together  with  the  arguments  onto  the 

network,  preferably  to  the  node  that  contains  the  data  object  that  is  the  receiver  of  the  call.  If 

the  process  is  expecting  a  result,  it  includes  a  return  address  at  the  end  of  the  message  and 

stores  a  word  tagged  CFUT  (context  future)  in  its  local  variable  that  is  to  receive  the  result.  J 

That  word  marks  that  variable's  value  as  unavailable  until  the  method  returns  a  value  using 

a  REPLY  message;  the  returned  value  is  written  over  the  CFUT.  Any  access  to  an  unavailable 
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variable  will  cause  the  process  to  wait  until  the  value  is  available,  thus  providing  automatic 
synchronization  of  data  dependencies.  While  a  process  is  waiting,  other  processes  may  run  on 
the  same  node. 

A  detailed  description  of  the  MDP  architecture  is  in  [9];  a  summary  is  presented  in  Appendix 
A.  The  formats  of  the  various  messages  and  the  operating  system  interface  is  in  Appendix  B, 
while  [12]  contains  a  high-level  and  slightly  obsolete  description  of  the  operating  system. 

MDPSim  [10]  is  an  instruction  level  simulator,  assembler,  and  debugger  used  to  run  MDP 
assembly  language  programs  and  test  the  operating  system.  It  is  also  the  current  target 
environment  of  the  compiler. 

The  Optimist  Compiler 
Goals 

The  main  goal  of  the  Optimist  compiler  is  to  produce  Concurrent  Smalltalk  code  that  is  as 
small  as  possible  without  sacrificing  speed.  In  almost  all  cases  optimizations  that  reduce 
space  also  reduce  speed,  but  there  are  a  few  cases  in  which  they  conflict;  in  those  cases  the 
decisions  were  made  in  favor  of  optimizing  space.  The  compiler  does  not  make  any 
optimizations  if  they  would  affect  the  semantics  of  the  Concurrent  Smalltalk  program.  There 
were  a  few  cases  (for  instance,  the  inline  coding  of  primitives)  in  which  highly  desirable 
optimizations  could  not  be  done  due  to  little-used  details  of  the  specification  of  Concurrent 
Smalltalk;  in  those  cases  the  semantics  were  modified  to  permit  efficient  compilation. 

Compilation  speed  was  not  a  major  goal  of  the  compiler  project.  Simplicity  and  flexibility 
were  considered  more  important  Thus,  there  are  numerous  portions  of  the  compiler  that 
could  be  accelerated  at  an  expense  of  simplicity  and  flexibility.  Still,  the  compiler  does 
achieve  reasonable  compilation  speed,  taking  between  one  and  fifteen  seconds  to  compile 
most  methods  on  a  Macintosh1  II. 

Implementation 

The  Optimist  compiler  is  written  in  Common  Lisp.  It  adheres  to  standard  Common  Lisp  as 

specified  in  [11]  with  the  exception  of  using  the  LOOP  iteration  macro  [3].  The  LOOP  macro  I 

is  itself  written  in  standard  Common  Lisp,  so  Optimist  should  run  on  any  machine  with  a 

faithful  implementation  of  Common  Lisp. 

Optimist  was  developed  on  a  Macintosh  using  Allegro  Common  Lisp  written  by  Coral 
Software  Corp.  and  Franz  Inc.  It  runs  on  a  2-megabyte  Macintosh  II.  It  was  successfully 
tested  on  Sun  Common  Lisp  developed  by  Sun  Microsystems,  Inc.  and  Lucid,  Inc.  and  on  a 
Symbolics  3600  workstation  running  Common  Lisp.  ! 

Contribution  to  MDP  Project 

The  Optimist  compiler  is  part  the  language  software  part  of  the  MDP  project.  Currently  it 
allows  execution  and  performance  measurements  of  Concurrent  Smalltalk  programs  on  the  J- 
Machine  simulator  [10].  In  the  future  it  will  serve  as  the  compiler  for  Concurrent  Smalltalk  J 

programs  for  the  actual  J-Machine. 

As  will  become  apparent  later,  though,  the  compiler’s  effects  on  the  MDP  projects  are  more 
profound,  as  implementing  the  compiler  did  help  solidify  the  system  software,  the  MDP 
Architecture,  and  the  definition  of  Concurrent  Smalltalk.  Moreover,  an  analysis  of  the  code 
output  by  the  compiler  indicates  that  the  original  estimates  of  the  amount  of  time  it  takes  to  j 
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receive  and  process  a  message  were  too  low,  although  it  is  not  yet  clear  by  how  much.  Fur¬ 
thermore,  despite  the  optimizations,  the  size  of  the  code  output  by  the  compiler  was  larger 
than  was  anticipated,  thereby  forcing  a  reconsideration  of  the  amount  of  memory  accessible 
to  the  MDP. 

Outline 

The  next  chapter,  Concurrent  Smalltalk,  contains  a  quick  introduction  to  the  Concurrent 
Smalltalk  language  as  well  as  the  differences  between  the  language  as  given  in  other  sources 
and  the  Optimist  implementation  of  it. 

The  Compiler  Overview  chapter  follows.  This  chapter  presents  a  basic  overview  of  the 
compiler  and  introduces  the  major  sections  of  the  compiler.  It  is  followed  by  more  detailed 
chapters  on  each  of  the  basic  sections,  roughly  in  the  order  in  which  data  flows  within  the 
compiler.  While  reading  the  basic  sections  it  might  be  helpful  to  refer  to  the  Examples 
chapter  and  Appendix  C.  The  Examples  chapter  examines  the  step-by-step  compilation  of 
a  sample  Concurrent  Smalltalk  method.  It  shows  in  a  concrete  example  how  the  compiler's 
subsystems  fit  together  and  how  they  contribute  to  the  final  output.  Appendix  C  contains 
the  descriptions  of  the  utilities  used  by  the  other  compiler  sections;  understanding  the 
utilities  available  to  the  other  sections  may  be  helpful  in  understanding  what  the  other 
sections  do. 

There  are  many,  many  details  that  have  to  be  considered  in  writing  a  compiler,  and  including 
them  all  in  *his  thesis  would  make  it  exceedingly  long  (and  boring).  Thus,  many  aspects  of 
the  compiler's  operations  have  been  simplified  or  omitted  even  in  the  detailed  descriptions. 
For  the  definitive  information  on  how  a  particular  subsystem  works  please  refer  to 
Appendix  D,  which  contains  the  complete  listing  of  the  compiler.  Appendices  A  and  B  are 
specifications  of  the  compiler's  assumptions  about  the  target  machine;  the  information  there 
may  be  useful  in  understanding  the  compiler's  output. 

Appendix  E  is  an  Optimist  user's  manual  and  contains  instructions  for  actually  running  the 
compiler. 

Finally,  the  results  and  experiences  with  the  compiler  are  given  in  the  Conclusion  chapter, 
which  also  contains  recommendations  for  future  work  and  improvements. 
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The  language  Concurrent  Smalltalk  was  developed  by  William  Dally  [5].  It  is  a  concurrent 
version  of  the  Smalltalk-80  language  [8].  As  extensions  of  Smalltalk-80,  it  includes  the 
abilities  to  send  messages  without  waiting  for  replies,  concurrently  access  objects,  and  create 
objects  that  are  distributed  over  the  nodes  of  the  machine.  A  recent  description  of  the 
Concurrent  Smalltalk  language  together  with  some  examples  is  in  [71. 

Reality 

The  version  of  Concurrent  Smalltalk  supported  by  this  compiler  does  not  include  distributed 
objects  because  they  are  not  supported  by  the  operating  system  [12].  Nevertheless,  once 
distributed  objects  are  added  to  the  operating  system,  the  changes  to  be  made  to  the  compiler 
will  be  minimal.  Other  features  not  yet  supported  due  to  lack  of  operating  system  support 
and  a  limited  amount  of  time  include  block  scoping  and  global  variables. 

Unlike  the  infix  description  of  Concurrent  Smalltalk  in  [5],  the  source  code  for  the  compiler 
uses  the  prefix  format  that  looks  like  Lisp  code.  There  is  no  semantic  difference  between  the 
two  formats,  and  they  can  be  converted  one-to-one  into  each  other. 

Syntax 

The  syntax  of  Concurrent  Smalltalk  accepted  by  the  compiler  is  given  in  Table  2-1. 

A  program  is  a  sequence  of  definitions.  The  definitions  that  are  currently  supported  are 
constant,  class,  and  method  definitions.  In  addition,  a  file  inclusion  facility  is  provided  by 
the  Load  statement,  which  includes  the  specified  file  at  the  point  of  the  Load  statement. 

A  constant  definition  defines  a  constant  named  <constant-name>.  The  constant  can  be 
either  an  integer  or  a  named  symbol.  Once  a  constant  is  defined,  it  may  not  be  redefined  or 
changed.  Constants  encountered  in  methods  are  replaced  by  their  values  at  compile  time. 
Predefined  constants  are  listed  in  Table  2-2. 

A  class  definition  defines  a  new  Concurrent  Smalltalk  class.  A  class  is  a  template  for 
specifying  objects  and  methods.  Each  object  belonging  to  the  class  contains  the  instance 
variables  defined  in  the  class  definition  as  well  as  the  instance  variables  inherited  from  its 
superclasses,  if  any.  If  an  instance  variable  is  specified  that  has  the  same  name  as  an 
instance  variable  of  one  of  the  superclasses,  the  new  instance  variable  shadows  the  old  one  in 
the  definitions  of  methods  for  the  new  class. 

A  few  methods  are  automatically  defined  when  a  class  is  defined.  Specifically,  for  each 
instance  variable  a  method  is  defined  with  the  same  name  as  the  instance  variable  that, 
when  called  on  an  object  of  the  given  class,  returns  the  value  of  that  instance  variable.  These 
methods  are  called  accessor  methods. 

A  method  definition  defines  a  method  named  <method-name>  for  class  <class-name>  and  any 
classes  derived  from  that  class  (unless  that  method  is  overridden  by  another  method  defined 
with  the  same  name  for  a  subclass).  Each  method  is  allowed  zero  or  more  formal  arguments 
as  well  as  zero  or  more  local  variables  that  exist  for  the  duration  of  the  method's  execution. 
The  names  of  these  are  specified  in  the  method  definition.  The  last  item  in  the  method 
definition  is  the  definition  of  the  actual  method  code,  given  as  a  series  of  expressions. 
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When  a  method  is  called,  the  values  of  the  formals  are  computed  and  assigned  to  the  formats. 
After  all  formals  are  computed,  execution  of  the  method's  expressions  proceeds  as  if  the 
expressions  were  enclosed  in  an  implicit  block — initially  the  first  expression  is  evaluated, 
then  the  second  one,  and  so  forth.  The  value  of  the  implicit  block,  which  is  the  value  of  the 
last  expression,  is  returned  to  the  caller  unless  an  exit  statement  is  encountered  first. 

Table  2*1.  Concurrent  Smalltalk  Syntax 

<program>  :>  <definttion>* 

<definition>  (Constant  <constant-name>  <value>)  | 

(Class  <cJass-name>  (<superclass-name>*)  <instance-var-name>* )  | 
(Method  <class-name>  <method-name>  (<formal-name>*') 
«local-name>*)  <expression>* )  | 

(Load  "file-name") 

<value>  <irrteger>  |  <symbol-name> 

<expressk>n>  :>  <integer>  | 

(quote  <symbo(-name>)  | 

’  <symbol -name>  | 
self  | 

<formal-name>  | 

<local-name>  | 

<i  nstance-var-name>  | 

<constant-name>  | 

<method-name>  | 

(<method-expression>  <receiver-expression>  <expression>* )  | 

(set  <target-name>  <expression>)  | 

(cset  <target-name>  <expression>)  | 

(touch  <expression>)  | 

(new  <class-name> )  | 

(if  <expression>  <expression>  [<expression>])  | 

(begin  <expression>*)  j 
( reply  <expression> )  | 

(return  <expressk>n>)  | 

(exit) 

<target-name> <local-name>  |  <instance-var-name> 

Table  2-2.  Predefined  Constants 

Constant  Value 

T  TRUE 

TRUE  TRUE 

FALSE  FALSE 

NIL  NIL 


Expressions 

As  shown  in  Table  2-1,  an  expression  is  either  a  constant,  a  reference  to  a  variable,  a  call,  or 
one  of  the  control  constructs.  Each  expression  returns  a  value  that  may  be  used  or  ignored. 

The  allowed  constant  expressions  are  integers,  quoted  symbols,  names  of  previously  defined 
constants,  and  method  names.  These  all  evaluate  to  their  own  values.  Variable  expressions 
may  refer  to  formal,  local,  or  instance  variables,  as  well  as  self,  which  is  the  object  on  which 
the  method  was  called.  These  expressions  evaluate  to  the  variables'  current  values. 
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A  method  call  is  specified  by  giving  the  method  name  followed  by  the  receiver  (the  object  to 
which  the  method  is  applied)  as  well  as  the  method's  arguments,  if  any.  Called  methods 
execute  concurrently  with  the  caller  method  unless  some  form  of  synchronization  such  as  set 
or  touch  is  used.  The  order  of  evaluation  of  arguments  is  not  specified;  in  fact,  some  of  them 
may  be  evaluated  in  parallel,  and  some  may  not  be  evaluated  at  all  if  they  are  not  necessary. 
The  method  name  does  not  have  to  be  a  constant;  in  fact,  it  can  be  any  expression. 

Set  and  cset  assign  values  of  expressions  to  variables  which  must  be  either  instance 
variables  or  local  variables  (assignments  to  formals  are  not  allowed).  The  value  of  the 
expression  is  the  value  assigned  to  the  variable.  The  difference  between  set  and  cset  is 
that  set  waits  until  the  value  is  calculated  before  proceeding,  while  cset  proceeds 
immediately,  allowing  the  calculation  of  the  value  to  execute  concurrently  with  the  calling 
method  until  the  value  is  actually  needed;  if  the  value  is  not  ready  at  that  point,  the  calling 
method  will  wait  until  the  value  is  available.  This  synchronization  is  transparent  to  the 
programmer.  Thus,  csets  should  be  used  wherever  possible  to  improve  performance  (and 
decrease  code  size). 

Touch  is  like  set  in  that  it  evaluates  the  expression  and  waits  until  the  value  is  available 
before  proceeding.  It  returns  the  value  of  the  expression. 

New  creates  and  returns  a  new  object  of  the  specified  class.  The  object  is  not  initialized. 

If  evaluates  the  first  expression,  which  must  return  either  TRUE  or  FALSE.  If  it  returns 
TRUE,  the  second  expression  is  evaluated  and  its  value  returned;  otherwise,  the  third 
expression,  if  any,  is  evaluated  and  its  value  returned.  If  there  is  no  third  expression,  the 
value  is  NIL.  if  does  not  wait  until  its  value  is  available  before  returning. 

Begin  evaluates  the  expressions  one  by  one  and  returns  the  value  of  the  last  one.  Begin 
does  not  wait  until  its  value  is  available  before  returning. 

Reply  evaluates  its  expression  and  replies  the  value  of  the  expression  to  the  caller  of  the 
current  method.  Execution  then  proceeds  with  the  next  statement  of  the  current  method,  if 
any.  Exit  terminates  the  processing  of  the  current  method  without  sending  a  reply,  which 
may  cause  the  caller  method  to  hang  if  it  expected  a  reply.  Return  is  like  reply  except  that 
after  replying  the  value  of  expression,  it  performs  an  exit.  Although  return  is  a  safe 
statement,  reply  and  exit  should  be  used  with  caution,  as  exit  may  cause  the  caller  to 
hang,  while  reply  may  cause  the  caller  to  crash  if  two  replies  are  inadvertently  sent.  When 
using  reply  it  is  important  to  note  that  there  is  an  implicit  reply  of  the  last  expression  in 
the  method  code  that  is  always  executed  unless  an  exit  is  called  first;  thus,  every  explicit 
reply  must  be  followed  by  an  explicit  exit. 

Primitives 

Primitive  classes  are  provided  for  reasons  of  efficiency  and  convenience.  Certain  primitive 
operations  on  primitive  classes  are  compiled  into  single  assembly  language  instructions 
instead  of  method  calls,  improving  their  speed  greatly.  The  four  primitive  classes  are  listed 
in  Table  2-3. 

Other  primitive  classes  may  be  defined  by  methods  written  in  assembly  language  and  linked 
with  the  programs  generated  by  the  compiler.  Arrays  are  defined  in  this  way. 

Certain  method  names  are  reserved  as  primitives  that  compile  to  assembly  language 
instructions.  These  are  listed  in  Table  2-4. 
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Table  2-3.  Primitive  Classes 

Class  Values 

integer  Arbitrary-sized  integers 

symbol  Symbols,  including  all  symboEc  constants  and  nil,  but  not  true  and  false 
Boolean  The  booleans  true  and  false 

Float  Floating-point  numbers  (not  implemented  in  operating  system) 


Table 

2-4.  Primitive  Methods 

Name 

Number  of  arguments  Action 
(Including  receiver) 

neg 

Integer 

1 

Return  -argl. 

+ 

Integer 

0  or  more 

Return  the  sum  of  the  integer  arguments. 

- 

Integer 

2 

Return  the  difference  of  the  two  arguments. 

* 

Integer 

0  or  more 

Return  the  product  of  the  arguments. 

// 

Integer 

2 

Return  argl  /arg2,  rounding  towards  -®°.  An  error 
Occurs  if  arg2«0. 

mod 

Integer 

2 

Return  argl-  (argl//arg2)  *arg2.  An  error  occurs 
H  arg2=0. 

ash 

Integer 

2 

Return  argi*2ar|32,  rouncfing  towards  -~  if  arg2  is 
negative. 

min 

Integer 

1  or  more 

Return  the  smallest  argument. 

Boolean 

1  or  more 

Return  the  and  of  the  arguments. 

max 

Integer 

1  or  more 

Return  the  largest  argument. 

Boolean 

1  or  more 

Return  the  or  of  the  arguments. 

not 

Boolean 

1 

Return  the  logical  negation  of  the  argument. 

and 

Boolean 

0  or  more 

Return  the  logical  AND  of  the  arguments. 

or 

Boolean 

0  or  more 

Return  the  logical  inclusive  OR  of  the  arguments. 

xor 

Boolean 

0  or  more 

Return  the  logical  exclusive  OR  of  the  arguments. 

lognot 

Integer 

1 

Return  the  logical  negation  of  the  argument. 

Boolean 

1 

Return  the  bitwise  complement  of  the  argument. 

logand 

Integer 

0  or  more 

Return  the  bitwise  AND  of  the  arguments. 

Boolean 

1  or  more 

Return  the  logical  AND  of  the  arguments. 

logor 

Integer 

0  or  more 

Return  the  bitwise  inclusive  OR  of  the  arguments. 

Boolean 

1  or  more 

Return  the  logical  inclusive  OR  of  the  arguments. 

logxor 

Integer 

0  or  more 

Return  the  bitwise  exclusive  OR  of  the  arguments. 

Boolean 

1  or  more 

Return  the  logical  exclusive  OR  of  the  arguments. 

< 

Integer 

2 

Return  true  if  argi<arg2  and  false  otherwise. 

Boolean 

2 

Return  (NOT  argl)  AND  arg2. 

<= 

Integer 

2 

Return  true  if  argi£arg2  and  false  otherwise. 

Boolean 

2 

Return  (NOT  argl)  OR  arg2. 

> 

Integer 

2 

Return  true  if  argi>arg2  and  false  otherwise. 

Boolean 

2 

Return  argl  AND  (NOT  arg2). 

>= 

Integer 

2 

Return  true  if  argi2arg2  and  false  otherwise. 

Boolean 

2 

Return  argl  OR  (NOT  arg2). 

= 

Integer 

2 

Return  true  if  argi=arg2  and  false  otherwise. 

Boolean 

2 

Return  true  if  argi=arg2  and  false  otherwise. 

Symbol 

2 

Return  true  if  argi=arg2  and  false  otherwise. 

<> 

Integer 

2 

Return  true  if  argi*arg2  and  false  otherwise. 

Boolean 

2 

Return  true  if  argi*arg2  and  false  otherwise. 

Symbol 

2 

Return  true  if  argi*arg2  and  false  otherwise. 

eq 

Any  combination 

2 

Return  true  if  argi=arg2  and  false  otherwise. 

neq 

Any  combination 

2 

Return  true  if  argi*arg2  and  false  otherwise. 

Eq  and  neq  are  pointer  comparisons  and  cannot  be  redefined. 
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The  rationale  for  having  //  and  mod  round  towards  -«•  is  that  this  definition  allows  the  use  of 
arithmetic  shifts  to  divide  and  logical  AND  to  find  the  remainder  when  the  divisor  is  an 
integral  power  of  two. 

If  a  primitive  method  is  called  with  an  argument  that  is  not  one  of  the  primitive  classes  it 
recognizes,  the  actual  method  for  the  class  is  found  and  executed  (this  is  not  yet  implemented 
in  the  operating  system).  Thus,  it  is  possible  to  define  a  class  of  type,  say,  complex,  and 
define  a  method  *  for  numbers  of  that  type.  That  method  will  be  called  whenever  *  is  used  on 
a  number  of  type  complex  (regardless  of  whether  that  number  is  the  receiver  or  the  ar¬ 
gument). 

It  should  be  noted,  though,  that  since  the  compiler  generates  assembly  language  instructions 
for  the  primitive  methods  instead  of  method  calls,  methods  overriding  primitives  must  satisfy 
certain  identities  which  are  listed  in  Table  2-5. 


Table  2-5.  Identities  among  Primitive  Methods 

«  +  is  associative  and  commutative. 

•  0  is  an  identity  for  +. 

•  (-  a  b)  -  (+  a  (neg  b)). 

•  *  is  commutative  with  scalar  constants  and  associative. 

•  l  is  an  identity  for*. 

•  (*  a  2e)  -  (ash  a  e). 

•  (//  a  2°)  -  (ash  a  -e). 

•  (ash  0  a)  -  0. 

•  (ash  a  0)  -  a. 

•  min  and  max  are  associative  and  commutative. 

•  (not  (not  a) )  -  a. 

•  and,  or,  and  xor  are  associative  and  oommutative. 

•  (and  a  FALSE)  -  FALSE. 

•  (and  a  TRUE)  *  a. 

•  (or  a  FALSE)  =  a. 

•  (or  a  TRUE)  -  TRUE. 

•  (xor  a  FALSE)  **  a. 

•  (xor  a  TRUE)  *  (not  a). 

•  (lognot  (lognot  a) )  =  a. 

•  logand,  logor,  and  logxor  are  associative  and  commutative. 

•  (logand  a  0)  -  0. 

•  (logand  a  -1)  *  a. 

•  (logor  a  0)  =  a. 

•  (logor  a  -1)  -  -1. 

•  (logxor  a  0)  »  a. 

•  (logxor  a  -1)  »  (lognot  a). 

•  (<  a  b)  -  (not  (>=  a  b) ) . 

•  (>  a  b)  -  (not  (<-  a  b)). 

•  (*  a  b)  -  (not  (<>  a  b) ) . 

•  (<  a  b)  -  (>  b  a). 

•  (<=  a  b)  -  (>*  b  a). 

•  (-  a  b)  =  (=  b  a) . 

•  (<>  a  b)  =  (<>  b  a). 

These  identities  have  been  carefully  selected  to  allow  efficient  implementation  of  primitive 
operations  without  sacrificing  functionality.  Some  identities  have  been  omitted  on  purpose. 
For  example,  *  does  not  have  to  be  commutative  in  general,  nor  does  ( *  a  0 )  have  to  equal 
0.  Not  requiring  these  identities  allows  *  to  be  used  to  multiply  quaternions  and  matrices. 
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Chapter  3.  Compiler  Overview 

The  compiler  is  organized  into  several  sections  which  perform  a  series  of  transformations  on 
the  code.  These  sections  are  illustrated  in  Figure  3-1.  The  Front  End  and  its  library 
handlers  were  originally  written  by  Prof.  William  Dally  and  Andrew  Chien;  I  made 
modifications  to  them  to  adapt  them  to  this  compiler,  fix  a  few  minor  problems,  and  improve 
the  syntax  of  Concurrent  Smalltalk.  Everything  else  is  entirely  my  own. 


CST  Source  Code 


MDP  Assembly  Code 


Figure  3-1.  Compiler  Block  Diagram. 
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Utilities 

There  are  a  few  Lisp  data  types  and  functions  that  are  used  throughout  the  compiler.  These 
functions  include  an  efficient  implementation  of  general  sets  of  nonnegative  integers,  directed 
graphs  (digraphs),  and  generalized  algorithms  such  as  mapping,  basic  block-finding,  and 
calculating  dataflow  information  by  relaxation  on  digraphs.  These  functions  and  data  types 
have  been  collected  in  the  Utiities  file  and  are  described  in  Appendix  C. 


Front  End 

The  source  code  is  converted  by  the  Front  End  into  a  language  called  I-Code  that  is  similar  to 
the  "quadruples”  code  that  many  compilers  use.  The  I-Code  is  at  a  somewhat  higher  level 
than  the  quadruples  code,  though,  in  that  it  specifies  units  such  as  entire  procedure  calls  in 
single  instructions.  The  I-Code  also  allows  for  the  possibility  of  having  more  than  one  source 
language  compile  into  MDP  assembly  language  code  or  having  the  same  source  language 
compile  into  several  assembly  languages.  The  syntax  of  the  I-Code  is  given  in  Table  3-1. 

The  library  handler  is  really  part  of  the  Front  End.  Its  main  function  is  keeping  track  of  the 
classes  and  constants  that  have  been  defined.  As  such,  it  is  used  as  a  subroutine  by  other 
blocks  that  would  like  to  know  information  about  classes. 


Table  3*1.  I-Code  Syntax 


<method> 

< statements- 


<target> 


<slot> 


<constant> 


<statement>* 

(Csend  <target>  <selector-slot>  <receiver-sbt>  <argument-stot>*)  | 
(Touch  <source-slot>)  | 

(Move  <target>  <source-slot>)  | 

(New  <target>  <class-name>)  | 

(Reply  |  Reply-x  <sk)t>)  | 

(Return  |  Return-x  <SlOt>)  | 

(Label  <label>)  | 

(Jump  <labek>)  | 

(False  jump  <slot>  <label>) 

(temp  <name>)  | 

(var<name>)  | 

(ivar  <number>) 

(temp  <name>)  | 

(var  <name>)  | 

(ivar  <number»  | 

(arg<number»  | 

(const  <constant>)  | 

(method  <name>)  | 
self 

<integer>  |  <symbol>  |  nil  |  t  |  True  |  False 


The  correspondence  between  most  I-Code  statements  and  their  Concurrent  Smalltalk  counterparts  is 
straightforward.  The  only  differences  worth  noting  are  that  all  function  calls  compile  to  csends  and  that 
a  Concurrent  Smalltalk  set  does  an  automatic  touch  on  its  target  before  proceeding.  Reply-x  and 
return-x  will  be  used  to  implement  block  scoping  and  currently  perform  the  same  function  as  reply 
and  return. 
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Statement  Analyzer  and  Optimizer 

The  Statement  Analyzer  and  Optimizer  processes  the  I-Code  generated  by  the  Front  End  to 
produce  a  stmtgraph.  The  stmtgraph  is  a  directed  graph  implemented  with  the  digraph  data 
type  defined  in  Utilities  in  which  each  node  represents  an  I-Code  statement  (stmt)  and  each 
edge  represents  a  possible  flow  of  control  path  from  one  statement  to  another.  The  digraph 
contains  no  unconditional  branches,  as  these  are  represented  simply  by  connecting  the 
predecessor  statement  to  the  successor  statement  with  an  edge.  The  statements  allowed  in 
the  digraph  nodes  are  listed  in  Table  3-2.  They  are  similar  to  the  I-Code  statements,  but 
there  are  a  few  differences. 


Table  3-2. 

Possible  Stmts 

Operation 

enter 

Target 

Method 

Arguments 

csend 

rsend 

dest-slot 

(selector-slot  receiver-slot  argl-siot .. 
(selector-slot  receiver-slot  argl-siot . 

.  argn-slot) 

. .  argn-slot) 

primitive 

move 

touch 

new 

condition 

reply 

exit 

dest-slot 

dest-slot 

dest-slot 

primitive 

class-name 

condtion 

(receiver-slot  argl-siot ...  argn-slot) 
(source-slot) 

(source-slot) 

(source-slot) 

(source-slot) 

Any  fields  that  are  blank  are  set  to  nil.  The  primitive  statement  is  a  method  call  with  a  selector  that 
was  recognized  as  one  of  the  primitives  listed  in  Table  2-4.  The  enter  statement  is  placed  at  the  be¬ 
ginning  of  the  method  and  performs  some  initialization  functions.  The  condition  statement  corre¬ 
sponds  to  one  of  the  six  c*  the  MDP*s  conditional  branches;  condition  specifies  the  type  of  branch,  which 
may  be  one  of  the  following: 

bnii  Branch  if  source-slot  is  eq  to  nil 
bnnii  Branch  if  source-slot  is  not  eq  to  nil 

bf  Branch  if  source-slot  is  false 

bt  Branch  if  source-slot  is  t  rue 

bz  Branch  if  source-slot  is  -  to  0 

bnz  Branch  if  source-slot  is  <>  to  0 

The  rsend  statement  is  a  tail-forwarded  c send— the  result  of  the  rsend  is  sent  to  the  caller  of  this 
method  instead  of  this  method.  The  target  of  a  csend  may  be  NIL,  in  which  case  the  return  value  of  the 
csend  is  ignored. 

The  Statement  Analyzer  and  Optimizer  performs  all  of  the  compiler's  optimizations  that  are 
relevant  at  the  I-Code  level  of  abstraction.  These  optimizations  include  dead  code 
elimination,  move  elimination,  dataflow  transformations,  constant  folding,  tail  forwarding, 
and  merging  of  identical  statements  on  both  sides  of  forks  and  joins.  A  fork  is  a  statement 
with  more  than  one  outgoing  flow  of  control  path;  currently  conditions  are  the  only  forks. 
A  join  is  a  statement  with  more  than  one  incoming  flow  of  control  path. 

The  stmtgraph  produced  by  the  Statement  Analyzer  and  Optimizer  can  be  converted  back  into 
a  modified  version  of  plain  I-Code.  There  is  a  function  in  the  Statement  Analyzer  and 
Optimizer,  Output-Stmtgraph,  available  to  do  this  conversion;  the  function  is  useful  for  the 
purposes  of  debugging  as  well  as  using  the  Statement  Analyzer  and  Optimizer  to  optimize  I- 
Code  that  will  be  run  on  Andrew's  simulator  [7]. 
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Instruction  Generator 

The  Instruction  Generator  converts  the  stmtgraph  into  a  module,  which  is  another  digraph. 
The  nodes  of  a  module  represent  individual  MDP  assembly  language  instructions  as  opposed 
to  I-Code  statements.  As  in  the  stmtgraph,  the  edges  of  a  module  correspond  to  flow  of  control 
paths  through  the  instructions.  There  are  no  unconditional  branches  in  the  resulting  module. 
However,  unlike  in  the  stmtgraph,  the  instructions  in  the  module  are  ordered  in  a  linear 
sequence  that  represents  their  order  in  the  final  assembly  language  output. 

An  important  function  performed  by  the  Instruction  Generator  before  it  generates  code  is 
assigning  variables  to  locations.  Each  local  variable  and  temporary  can  be  assigned  to  either 
a  register  or  a  slot  in  the  context  object.  The  Instruction  Generator  tries  to  assign  as  many 
variables  as  possible  to  registers  and  use  as  few  context  slots  as  possible,  and  it  will  reuse 
registers  and  context  slots  whenever  possible. 

The  Instruction  Generator  performs  statement-specific  optimizations  on  I-Code  statements. 
It  also  keeps  track  of  the  values  of  the  MDP  registers  while  it  is  compiling,  allowing  it  to  use 
values  in  registers  whenever  available.  The  Instruction  Generator  does  not,  however,  perform 
any  final  peep-hole  optimizations  on  the  module. 

Assembly  Code  Generator 

The  Assembly  Code  Generator  inserts  branches  into  the  module  created  by  the  Instruction 
Generator  and  performs  several  peep-hole  optimizations  on  that  module.  The  important 
optimizations  include  shifting  instructions  wherever  possible  to  align  DC  instructions  to  word 
boundaries  and  combining  SEND  and  SENDE  instructions  to  SEND2  and  SEND2E.  The 
Assembly  Code  Generator  also  checks  each  branch  to  make  sure  that  the  branch  destination 
is  reachable  from  the  branch  source  within  the  limited  MDP  branching  range;  if  not,  the 
branch  is  replaced  by  a  long  branch.  This  process  also  involves  several  optimizations. 

Finally,  the  Assembly  Code  Generator  outputs  the  module  as  a  series  of  assembly  language 
statements.  The  resulting  file  can  be  read,  assembled,  and  executed  by  MDPSim,  and, 
hopefully,  eventually  by  a  working  J-Machine. 
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Chapter  4.  Front  End 

The  organization  of  the  Front  End  is  fairly  straightforward.  Since  the  prefix  Concurrent 
Smalltalk  code  is  in  the  form  of  lists  readable  by  the  Lisp  reader,  there  is  no  need  for  a 
parser — the  Front  End  routines  accept  list  structures  read  from  the  input  file.  There  are 
three  routines  in  the  Front  End  that  are  called  from  the  outside:  compile-class, 
compile-method,  and  instance-vars.  The  Front  End  also  maintains  three  global  lists: 
‘classes*,  a  list  of  all  defined  classes,  their  superclasses,  and  their  instance  variables; 
‘constants*,  a  list  of  all  defined  constants  and  their  values,  and  *globals*,  a  list  of  all  defined 
globals  and  their  values.  Globals  are  not  implemented  by  the  code  generator,  though, 
because  the  operating  system  does  not  provide  a  facility  for  them. 

;;  (dass  name  ({parent-classes})  {instance-variables}) 

(defun  compHe-dass  (form  output-stream) 

(let  ((class  (expand-dass  (cdr  form)))) 

(setq  *dasses*  (cons  dass  ‘classes*)) 

(if  output-stream  (make-accessor-methods  class  output-stream)) 
dass)) 

Compile-class  compiles  a  class  definition — it  checks  the  class  definition  for  validity;  calculates 
the  class's  instance  variables  by  concatenating  the  instance  variables  of  the  superclass,  if  any, 
with  the  new  instance  variables;  adds  the  new  class  to  ‘classes*;  compiles  the  accessor 
methods  for  the  class;  and  outputs  the  resulting  code  onto  a  stream. 

;;  (method  dass  method-name  ({args})  ({temps})  {statements}) 

(defun  compile-method  (form  &opt»nal  (output-stream  t)) 

(if  (<  (length  form)  6) 

(cat-error  *~&Method  missing  field  ~S"  form) 

(let  ((dass-name  (second  form)) 

(method-name  (third  form)) 

(args  (fourth  form)) 

(vars  (fifth  form)) 

(body  (nthcdr  5  form))) 

(let  ((icode  (compile-block  args  vars  (instance-vars  class-name)  body))) 

(if  output-stream 

(compile-icode  method-name  dass-name  (length  args)  icode  :output-stream  output-stream)) 
icode)))) 

Compile-method  is  the  general  Front  End  routine  for  compiling  a  method.  It  takes  a  Lisp  list 
that  is  the  definition  of  the  method  and  a  stream  onto  which  the  assembly  code  for  the 
compiled  method  should  be  written.  It  then  calls  compile-block  to  generate  the  I-Code  for  the 
method  and,  if  the  output  stream  is  non-nil,  oompile-icode  to  compile  the  I-Code  to  assembly 
language.  Finally,  compile-method  returns  the  I-Code  as  a  help  in  debugging. 

Compile-block  sets  up  a  few  dynamic  variables  (see  Appendix  D  for  details)  and  compiles  the 
statements  of  the  method  using  compile-expression. 
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;;;  compiles  an  expression  and  puts  the  result  in  slot 
;;;  if  slot  is  nil,  doesn't  put  the  result  anywhere. 

;;;  if  slot  is  '_unbound_  creates  a  temporary 
(defun  compile-expression  (slot  expr) 

;(format  ‘standard-output*  *~&compile-expression  ~S  ~S"  slot  expr) 

(if  (atom  expr) 

(compile-atom  slot  expr) 

(let  ((head  (car  expr))) 

(if  (eq  (symbol-type  head)  keyword) 

(ecase  head 

((set  cset)  (compile-set  slot  expr)) 

((return  retum-x)  (compile-return  head  slot  expr)) 

(reply 

(if  ‘anachronisms*  (compile-return  ’return  slot  expr) 

(compile-reply  ’reply  slot  expr))) 

(reply-x 

(if  ‘anachronisms*  (compile-return  'return-x  slot  expr) 

(compile-reply  'reply-x  slot  expr))) 

(forward  anachronism 
(if  (eq  (cadr  expr)  'requester) 

(compile-reply  'reply-x  slot  (list  'reply-x  (cddr  expr))) 

(cst-error  ‘-ACanl  reply  to  ~S*  (cadr-expr)))) 

(exit  (emit  '(exit))  slot) 

(iftrue  (oompile-iftrue  slot  expr)) 

(if  (compile-if  slot  expr)) 

(begin  (compile-begin  slot  expr)) 

(new  (compile-new  slot  expr)) 

(newco  (compile-newco  slot  expr)) 

(quote  (check-binding  slot  '(const  .(cadr  expr)))) 

(msg  (compile-message  slot  expr)) 

(send ; anachronism 
(compile-expression  slot  (cdr  expr))) 

(touch  (compile-touch  slot  expr))) 

(compile-aend  slot  expr))))) 

Compile-expression  takes  two  parameters:  a  slot  into  which  the  value  of  the  expression  is  to 
be  stored,  and  the  source  code  for  the  expression  to  be  compiled.  If  the  slot  is  the  symbol 
_unbound_,  compile-expression  creates  a  new  slot  and  stores  its  value  there. 
Compile-expression  returns  the  slot  into  which  the  value  of  the  expression  was  actually 
stored.  Numerous  routines  are  called  by  compile-expression,  one  for  each  type  of  Concurrent 
Smalltalk  source  statement.  They  are  all  quite  straightforward;  please  refer  to  Appendix  D 
for  their  listings.  The  only  two  routines  that  may  need  additional  explanation  are  symbol- 
type  and  check-binding. 

(defun  symbol-type  (expr) 

(cond  ((numberp  expr)  '(const  ,expr)) 

((not  (symbolp  expr))  nil) 

((eq  expr  ’self)  ’self) 

((eq  expr  ’super)  ’super) 

((eq  expr  ’group)  ’group) 

((member  expr  *vars‘)  '(var  .(index  expr  *vars*))) 

((member  expr  *args‘)  '(arg  .(index  expr  *args*))) 

((member  expr  *ivars‘)  '(ivar  .(index  expr  ‘ivars*))) 

((symbol-is-keyword?  expr)  keyword) 

((assoc  expr  ‘globals*)  '(global  ,expr)) 

((assoc  expr  ‘constants*)  '(const  ,(cdr  (assoc  expr  ‘constants*)))) 

(t  (list  ’method  expr)))) 

Symbol-type  returns  the  slot  corresponding  to  a  token  read  from  the  source  code  or  the  symbol 
keyword  if  the  token  is  one  of  the  Concurrent  Smalltalk  keywords.  It  implements  a  limited 
form  of  lexical  scoping  by  checking  for  the  local  definitions  before  the  global  definitions;  thus, 
a  local  definition  of  a  variable  may  shadow  the  global  definition  of  a  constant  or  even  a 
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Concurrent  Smalltalk  keyword.  If  none  of  the  other  definitions  fits,  symbol-type  assumes  that 
the  symbol  read  is  the  name  of  a  method. 

;;;  if  a  is  already  bound  move  b  to  a  and  return  a  otherwise  return  b 
(defun  check-binding  (a  b) 

(if  (eq  a  '.unbound  J 
b 

(if  (equal  a  b) 
a 

(progn  (if  a  (emit  '(move  ,a  ,b))) 
a)))) 

Check-binding  is  used  by  most  of  the  I-Code-generating  routines  to  place  the  result  in  the 
correct  slot  Many  of  the  routines  place  their  results  in  temporary  slots  and  later  use  check¬ 
binding  to  try  to  match  the  temporary  slot  (b)  with  the  slot  in  which  the  enclosing  statement 
expects  the  value  (a).  If  the  enclosing  statement  does  not  want  to  receive  the  result  of  the 
statement,  it  will  set  a  to  nil.  If  it  does  want  the  result  but  does  not  care  about  where  the 
result  should  be,  it  will  set  a  to  ’.unbound.,  and  check-binding  will  return  the  location  of  the 
result  that  will  subsequently  be  returned  to  the  routine  compiling  the  enclosing  statement. 
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Chapter  5.  Statement  Analyzer  and  Optimizer 

The  Statement  Analyzer  and  Optimizer  is  divided  into  several  sections  as  shown  in 
Figure  5-1. 


I-Code 


Postprocessed  Stmtgraph 

Figure  5-1.  Statement  Analyzer  and  Optimizer  Block  Diagram. 

The  preprocessor  performs  a  few  minor  transformations  to  the  I-Code.  Its  output  is  still  I- 
Code.  That  I-Code  is  passed  through  the  diagraphizer  and  canonarizer  to  produce  a 
stmtgraph.  The  stmtgraph  is  then  optimized  by  the  optimizer,  and  some  final  transformations 
are  done  by  the  postprocessor. 
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Preprocessor 

The  I-Code  preprocessor  performs  the  following  functions: 

*  It  adds  an  enter  statement  to  the  beginning  of  the  I-Code.  The  enter  statement 
will  later  compile  into  initialization  code  for  the  method. 

*  It  changes  all  existing  exit  statements  into  branches  to  one  exit  statement  at  the 
end  of  the  method.  That  exit  statement  will  later  compile  into  termination  code  for  the 
method,  and  having  only  one  exit  statement  may  save  a  few  instructions. 

*  It  changes  all  return  statements  into  moves  of  the  return  value  to  a  new  variable 
and  branches  to  one  reply  statement  at  the  end  of  the  method  that  then  falls  into  the  exit 
statement  Again,  merging  all  of  the  return  statements  is  likely  to  save  some  code. 

Diagraphizer  and  Canonarizer 

The  diagraphizer  converts  the  I-Code  to  a  stmtgraph.  It  does  this  in  two  stages.  First,  it  calls 
the  routine  diagraphize  to  translate  the  I-Code  structure  into  a  stmtgraph.  Diagraphize  scans 
the  I-Code,  replaces  all  branches  in  the  I-Code  with  edges  in  the  stmtgraph,  and  removes  all 
labels  from  the  code.  Next,  all  of  the  slots  in  the  stmtgraph  are  converted  into  the  form  used 
by  the  rest  of  the  compiler.  The  actual  syntax  of  the  slots  is  listed  at  the  beginning  of  the 
Stmt  file  in  Appendix  D.  The  slots  representing  local  variables  and  temporaries  generated  by 
the  Front  End  are  merged  into  one  category,  variables,  and  assigned  consecutive  variable 
numbers  starting  with  zero. 

The  preprocessor,  diagraphizer,  and  canonarizer  are  all  invoked,  one  after  another,  by  the 
function  input-icode,  which  also  removes  any  dead  code  left  over  by  disconnecting  unreachable 
stmtgraph  nodes  using  purge -unreachables-digraph  (See  Appendix  C). 


Statement  Optimizer 

;;;Perform  iterative  stmtgraph  optimizations  until  a  steady  state  is  reached. 

;;;Retum  the  stmtgraph. 

(defun  iterative-optimize-stmtgraph  (stmtgraph) 

(attribute-steady-state 
(stmtgraph-attributes  stmtgraph) 

(progn 

(when  ‘deiete-dead-defs*  (delete-dead-defs  stmtgraph)) 

(when  ‘delete-moves*  (delete-moves  stmtgraph)) 

(when  ‘delete-touches*  (delete-touches  stmtgraph)) 

(when  *dttow-optimizat»ns*  (calc-dflow  stmtgraph)) 

(when  ‘fold-constants*  (fold-constants  stmtgraph)) 

(when  ‘torward-sends*  (forward-sends  stmtgraph)) 

(fold-conditionals  stmtgraph)  ;This  must  not  be  disabled,  or  code  generator  will  faill 
(when  ‘merge-code* 

(merge-joins  stmtgraph) 

(merge-forks  stmtgraph)))) 
stmtgraph) 

The  Statement  Optimizer  repeatedly  tries  a  number  of  optimizations  on  the  stmtgraph  until 
none  of  them  changes  the  stmtgraph.  At  that  point  it  returns  the  stmtgraph.  The 
optimizations  attempted  are  listed  in  Figure  5-2  and  in  the  listing  above.  Most  optimizations 
can  be  disabled  by  setting  the  appropriate  parameters  to  nil.  The  optimizations  are 
described  in  more  detail  below. 
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Stmtgraph 


Stmtgraph 


Figure  5-2.  Statement  Optimizer  Block  Diagram. 

The  Statement  Optimizer  calls  the  above  optimization  routines  until  a  steady  state  is  reached  in 
which  none  of  the  optimization  routines  changes  the  stmtgraph. 
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Dead  Definition  Eliminator 

This  procedure  removes  all  attempts  to  store  values  into  dead  variables;  a  variable  is  dead  at 
a  particular  statement  if  that  variable's  value  at  that  statement  is  not  used  by  any  statement 
that  may  subsequently  execute.  Variables  that  are  not  dead  are  called  live.  The  Dead 
Definition  Eliminator  proceeds  to  eliminate  stores  to  dead  variables  by  first  using  micro-relax 
described  in  Utilities  to  calculate  which  variables  are  dead  and  which  are  live  at  every 
statement  in  the  stmtgraph.  It  then  scans  the  entire  stmtgraph  looking  for  stmts  whose  targets 
are  dead  local  variables.  Only  csend,  primitive,  move,  and  new  statements  can  be  found, 
since  only  those  Stmts  can  have  non-null  targets  (see  Table  3-2).  If  the  statement  is  a 
primitive,  move,  or  new,  it  is  removed,  as  removing  it  does  not  change  the  semantics  of  the 
program  other  than  perhaps  not  causing  an  error  that  would  otherwise  occur.  Csends  cannot 
be  safely  removed;  instead,  if  a  csend  has  a  target  that  is  dead,  the  target  is  set  to  nil, 
which  will  have  the  effect  of  asking  the  called  object  not  to  reply — still  an  improvement  over 
csending  to  a  dead  variable. 


Move  Eliminate! 

The  Move  Eliminator  attempts  to  remove  as  many  move  statements  as  possible  from  the 
stmtgraph.  It  works  by  scanning  the  entire  stmtgraph  looking  for  move  statements.  If  it  finds 
a  move  statement  with  an  identical  source  and  destination  slot,  that  move  statement  is 
removed  since  it  does  not  do  anything.  If  the  move  statement  moves  a  local  variable  to 
another  local  variable,  the  Move  Eliminator  tries  to  merge  the  two  local  variables  by 
renaming  one  of  them.  Before  doing  the  merge  it  checks  whether  the  variables  are 
simultaneously  live  at  any  point  in  the  Stmtgraph;  if  so,  the  merge  cannot  be  safely  performed, 
and  the  Move  Eliminator  abandons  trying  to  optimize  the  move.  Otherwise,  the  two  local 
variables  are  merged,  and  the  move  statement  removed. 


The  Move  Eliminator  complements  the  Dataflow  Optimizer.  Although  they  both  try  to 
optimize  move  statements,  each  is  able  to  handle  cases  that  the  other  cannot.  The  Move 
Eliminator's  optimizations  are  restricted  to  moves  with  identical  source  and  destinations  and 
moves  between  two  local  variables.  It  optimizes  these  two  cases  quite  well,  though.  On  the 
other  hand,  the  Dataflow  Optimizer  can  eliminate  moves  from  a  constant,  an  argument,  or  an 
instance  variable  to  a  local  variable,  but  with  somewhat  less  flexibility.  Figure  5-3  shows  an 
example  of  move  statements  that  cannot  be  eliminated  by  the  Dataflow  Optimizer  yet  which 
are  easily  handled  by  the  Move  Eliminator. 


Figure  5-3.  Move  Eliminator  Example. 

The  Move  Eliminator  is  able  to  remove  the  two  move  statements  (a«-b)  and  (a«-c)  in  the  above  ex¬ 
ample.  The  copy  propagation  algorithm  used  by  the  Dataflow  Optimizer  would  not  detect  the 
opportunity  to  remove  these  two  move  statements  because  the  value  of  a  at  the  return  statement 
is  neither  a  copy  of  b  nor  a  copy  of  c.  This  advantage  of  the  Move  Eliminator  has  great  practical 
significance — the  above  example  actually  does  occur  in  many  methods. 
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Touch  Eliminator 

The  Touch  Eliminator  eliminates  all  touch  statements  that  it  can  prove  are  superfluous.  A 
touch  statement  checks  that  its  argument's  value  is  available;  if  not,  it  waits  until  the  value 
is  available.  Currently  only  local  variables  can  contain  values  that  are  unavailable,  so  all 
touch  statements  referring  to  slots  other  than  local  variables  are  eliminated. 

Eliminating  touch  statements  that  do  refer  to  local  variables  is  harder,  but  there  are  a  few 
cases  in  which  it  is  safe  to  remove  the  touch  statements.  For  instance,  if  it  can  be  shown 
(using  relax-digraph  to  keep  track  of  which  variables  are  guaranteed  to  have  available  values 
even  after  some  of  the  later  optimizations  are  performed)  that  a  local  variable's  value  is 
always  available  when  the  touch  statement  is  executed,  the  touch  statement  can  be  safely 
removed.  Other  examples  of  touch  statements  that  can  be  removed  are  touches 
immediately  preceding  an  exit  statement  (the  exit  statement  touches  all  local  variables  to 
make  sure  that  their  values  are  available  anyway,  so  the  any  touch  statements  immediately 
preceding  it  are  superfluous),  and  touches  immediately  preceding  csend,  rsend,  touch, 
and  reply  statements  that  refer  to  the  variable  that  is  touched,  as  these  statements  will  al¬ 
ways  wait  for  the  value  of  the  variable  anyway. 

Dataflow  Optimizer 

The  Dataflow  Optimizer  uses  relax-digraph  to  perform  a  general  analysis  of  the  possible 
values  that  each  local  variable  could  have  at  all  statements  in  the  method.  It  is  an  extension 
of  the  copy  propagation  algorithms  used  in  compilers  such  as  the  one  described  on  page  637  of 
[2].  The  algorithm  makes  one  of  the  assertions  listed  in  Table  5-1  about  each  local  variable  at 
every  statement  in  the  stmtgraph.  If  the  Dataflow  Optimizer  cannot  determine  which 
assertion  in  Table  5-1  holds,  if  more  than  one  of  them  holds  (other  than  NIL),  or  if  none  of 
them  holds,  the  nil  assertion  is  conservatively  assumed. 

Table  5-1.  Dataflow  Assertions  about  Local  Variables 

Assertion  Meaning 

nil  None  of  the  other  assertions  holds. 

(move  <slot>)  A  copy  of  <stof>  (which  may  be  a  constant). 

(not  <sk>t»  The  primitive  not  applied  to  <slot>. 

(-  <slotl>  <sk>t2>)  The  primitive  «  applied  to  <slotl>  and  <slot2>. 

(<>  <slot1>  <slot2>)  The  primitive  <>  applied  to  <slot1>  and  <slot2>. 

(eq  <slot1>  <slot2>)  The  primitive  eq  applied  to  <slotl>  and  <slot2>. 

(neq  <slot1>  <slot2>)  The  primitive  neq  applied  to  <slotl>  and  <slot2>. 

The  Dataflow  Optimizer  then  examines  each  statement  in  the  stmtgraph  and  checks  whether 
any  local  variable  whose  value  is  used  by  that  statement  has  a  non-NlL  assertion.  If  so,  then 
it  tries  to  substitute  the  assertion  into  the  statement.  The  move  assertion  can  always  be 
substituted — the  move  assertion's  <slot>  is  substituted  instead  of  the  local  variable.  This 
copy  propagation  is  the  way  constant  move  statements  are  eliminated — if  a  constant  is  moved 
into  a  local  variable,  then  the  Dataflow  Optimizer  replaces  all  references  to  that  variable  with 
the  constant  itself,  and  the  Dead  Definition  Eliminator  is  then  able  to  eliminate  the  move 
statement  because  its  value  is  not  used  by  any  statement. 

The  other  assertions  are  substituted  only  in  special  circumstances.  The  not  assertion  is 
substituted  into  another  not  primitive  to  yield  a  move  statement:  (not  (not  x) )  =  x. 
Similarly,  not  can  be  merged  with  eq  to  make  a  neq  statement,  neq  to  eq,  =  to  <>,  and  <>  to 
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However,  the  principal  reason  for  keeping  track  of  the  not,  *,  <>,  eq,  and  neq  assertions  is 
for  their  use  in  conditional  branches.  Statements  such  as 

(if  (-  a  0)  _.)  Of  (if  (not  (eq  a  nil) )  _.) 

occur  frequently  in  Concurrent  Smalltalk  code,  and  they  should  not  generate  calls  to’the  «, 
eq,  and  not  primitives  because  these  operations  can  be  done  with  conditional  branches. 
Therefore,  if  the  Dataflow  Optimizer  encounters  a  bt  or  bf  condition  (see  Table  3-2),  and  if 
there  is  an  assertion  about  the  condition's  source  slot,  then  it  does  the  following; 

•  If  the  assertion  is  not,  the  condition's  source  slot  is  replaced  with  the  assertion's 
slot  and  the  meaning  of  the  branch  is  reversed. 

•  If  the  assertion  is  -  or  <>  and  one  of  the  assertion's  slots  is  0,  the  condition's  source 
slot  is  replaced  with  the  assertion's  other  slot  and  the  condition  type  changed  to  bz  or  bnz. 

•  If  the  assertion  is  eq  or  neq  and  one  of  the  assertion's  slots  is  nil,  the  condition's 
source  slot  is  replaced  with  the  assertion's  other  slot  and  the  condition  type  changed  to  bnil 
or  bnnil. 

In  all  of  the  above  cases  the  Dataflow  Optimizer  does  not  remove  the  intermediate  not,  <>, 
eq,  and  neq  statements  that  may  no  longer  be  needed.  Instead,  it  relies  on  the  Dead 
Definition  Eliminator  to  eliminate  them  because  their  results  are  no  longer  used.  If  it  turns 
out  that  the  intermediate  values  generated  by  not,  »,  <>,  eq,  or  neq  are  actually  used 
somewhere  else,  the  Dead  Definition  Eliminator  will  not  eliminate  these  intermediate 
statements,  and  the  Dataflow  Optimizer  might  have  increased  the  code  size  slightly,  but  this 
case  does  not  occur  often. 

Constant  Folder 

Although  the  Dataflow  Optimizer  may  substitute  constants  into  primitive  statements,  it  does 
not  simplify  the  resulting  statements.  For  example,  as  a  result  of  a  substitution,  a  primitive 
statement  that  adds  a  and  b  might  be  changed  to  a  primitive  statement  that  adds  1  and  3. 
The  Constant  Folder's  task  is  to  simplify  primitive  constant  expressions  as  far  as  possible.  It 
knows  the  rules  in  Table  2-5  and  applies  them  to  primitive  statements.  For  example,  it 
converts  (primitive  b  +  0  a)  into  (move  b  a).  It  is  capable  of  collecting  constants 
together,  so  (primitive  b  +  -3  a  7  -4)  is  also  converted  to  (move  b  a ),  which  may  be 
later  eliminated  by  the  Move  Eliminator. 

The  Constant  Folder's  optimizations  are  not  limited  to  primitives.  It  also  examines 
conditions  and  checks  whether  they  would  always  branch  one  way  (i.e.  if  bt  has  an 
argument  that  is  true  or  false,  if  bnz  is  invoked  on  3,  bnil  invoked  on  a  symbol,  etc.).  If 
so,  then  the  condition  is  removed,  as  is  the  stmtgraph's  “dead”  flow  of  control  edge  originating 
from  the  condition.  Since  removing  an  edge  may  produce  dead  code,  the  Constant  Folder 
Anally  calls  purge-unreachables-tfgraph  on  the  stmtgraph  to  make  sure  that  any  new  dead  code 
is  disconnected  from  the  stmtgraph. 

Tail  Forwarder 

The  tail  forwarder  produces  the  MDFs  equivalent  of  tail  recursion.  It  is  often  the  case  that 
the  value  returned  by  a  Concurrent  Smalltalk  method  is  the  value  returned  by  the  last 
statement  of  that  method,  and  that  statement  is  often  a  method  call.  An  example  of  this 
phenomenon  is  an  iterative  definition  of  the  factorial  function  such  as 
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(Method  integer  factorial  (n)  () 

(if  (■  self  0)  n  (factorial  (-  self  1 )  (*  n  self)))) 

If  self  is  not  equal  to  zero,  the  factorial  method  calls  factorial  and  immediately  returns  the 
result  There  is,  however,  no  fundamental  reason  why  factorial  should  wait  for  the  result  of 
the  recursive  call  to  factorial  only  to  return  it  to  the  caller;  on  the  contrary,  it  would  be  better 
if  it  could  just  tell  the  recursive  factorial  call  to  return  its  result  to  the  caller.  This  way  the 
returning  process  would  be  significantly  faster,  and,  more  important,  factorial  can  deallocate 
its  context  and  cease  execution  as  soon  as  it  sends  the  recursive  call  to  factorial.  This  way 
factorial  runs  in  constant  space  (at  least  until  the  numbers  get  too  large  to  fit  in  a  word)  as 
opposed  to  space  proportional  to  n  because  the  contexts  of  tail-forwarded  factorials  do  not  have 
to  be  stored. 

The  operation  of  the  Tail  Forwarder  is  simple.  The  Tail  Forwarder  scans  the  stmtgraph 
looking  for  csend  statements  that  store  their  results  in  local  variables.  If  it  finds  such  a 
csend  statement,  it  checks  whether  the  statement  following  it  is  a  reply  statement  of  the 
same  variable  and  that  variable  is  dead  afterwards.  If  so,  the  Tail  Forwarder  changes  the 
csend  statement  into  an  rsend  and  connects  it  to  the  statement  following  the  reply 
statement. 

Conditional  Folder 

The  Conditional  Folder  is  a  very  simple  optimization.  It  scans  the  stmtgraph  for  conditionals 
both  of  whose  branches  point  to  the  same  statement.  Any  such  conditionals  are  removed. 
Although  such  conditionals  do  not  normally  appear  in  source  Concurrent  Smalltalk  code,  they 
can  be  created  as  a  result  of  some  other  optimizations  such  as  the  implicit  dead  code 
elimination  in  the  Diagraphizer,  the  Reply  Forwarder,  and  Fork  and  Join  Mergers. 

Fork  and  Join  Mergers 

These  two  optimizations,  if  they  can  be  applied,  often  produce  significant  savings  in  the 
output  code  size.  They  try  to  consolidate  similar  statements  on  both  sides  of  forks 
(conditionals)  and  joins  (places  where  two  paths  of  control  flow  merge)  in  the  stmtgraphs. 
Currently  they  only  consider  the  first  statements  after  the  forks  or  before  the  joins,  but  they 
can  be  extended  to  consider  other  statements  as  well. 

The  Fork  Merger  considers  every  conditional  in  the  slmtgraph.  For  each  conditional  it  checks 
whether  the  statements  following  it  are  of  the  same  type  (both  are  csends,  rsends,  the  same 
kind  of  primitive,  reply,  etc.).  If  the  types  match,  if  the  statements’  arguments  (but  not 
necessarily  targets)  are  identical,  if  there  are  no  flow-of-control  edges  other  than  from  the 
conditional  entering  either  of  the  statements,  and  if  neither  of  the  statements  writes  to  the 
variable  used  by  the  conditional  statement,  then  the  two  statements  after  the  conditional  are 
merged  into  one  statement  before  the  conditional.  If  the  targets  of  the  two  statements  were 
originally  different,  then  the  new  statement  before  the  conditional  writes  its  result  into  a 
temporary  variable,  and  two  move  statements  from  the  temporary  variable  to  the  two 
variables  where  the  result  would  have  gone  are  placed  after  the  conditional.  These  move 
statements  are  often  later  eliminated  by  the  Move  Eliminator. 

The  Join  Merger  operates  in  a  manner  similar  to  the  Fork  Merger  except  that  it  does  not 
have  to  worry  about  interaction  with  the  condition  variable  because  there  is  none.  For  two 
statements  to  be  considered  by  the  Join  Merger  to  be  similar,  they  have  to  have  identical 
targets  and  the  same  number  of  arguments,  but  their  arguments  need  not  be  the  same.  Move 
statements  are  generated  to  copy  any  differing  arguments  into  temporaries  before  the  join, 
and  the  combined  statement  after  the  join  will  use  the  temporaries  instead  of  the  original 
arguments.  Again,  these  move  statements  are  often  eliminated  by  the  Move  Eliminator. 
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Although  more  than  two  paths  of  control  flow  can  join  at  the  same  place,  the  Join  Merger  only 
considers  them  pairwise;  if  more  than  two  paths  can  be  merged,  initially  only  two  will  be 
merged,  and  the  other  ones  will  be  merged  in  a  later  pass. 

In  order  to  avoid  becoming  stuck  in  an  infinite  loop  generating  move  statements,  the  Fork 
and  Join  Mergers  do  not  consider  move  statements  to  be  similar  unless  both  their  sources  and 
destinations  are  identical;  under  this  restriction  the  operations  of  the  Fork  and  Join  Mergers 
must  always  terminate  because  each  successful  merge  either  reduces  the  number  of  non¬ 
move  statements  in  the  Stmtgraph  by  one  (and  may  introduce  many  additional  move 
statements)  or  removes  one  move  statement  from  the  stmtgraph. 

Merging  similar  statements  instead  of  only  identical  ones  is  an  important  feature  of  the  Fork 
and  Join  Mergers;  often  candidate  statements  differ  only  in  that  their  results  or  arguments 
involve  different  temporaries,  and  the  Fork  and  Join  Mergers  will  merge  these  statements 
anyway,  while  the  differing  temporaries  themselves  will  likely  be  merged  later  by  the  Move 
Eliminator.  Moreover,  sometimes  the  Join  Merger  becomes  bolder  and  merges  two  com¬ 
pletely  different  csends  or  rsends  (as  long  as  they  have  the  same  number  of  arguments).  In 
fact,  since  method  selectors  are  treated  just  like  any  other  arguments,  I  have  seen  compiled 
code  in  which  the  Join  Merger  merged  two  csends  or  rsends  calling  different  methods,  a 
very  unusual  optimization  indeed!  In  each  branch  just  before  the  join,  the  resulting  object 
code  copied  the  differing  method  arguments  into  the  MDFs  registers  and  stored  the  appro¬ 
priate  method  selector  in  a  register.  After  the  join  was  common  code  that  sent  the  message 
given  the  method  selector  and  arguments  in  the  registers.  Since  the  code  to  send  a  message 
is  long  compared  to  the  code  to  load  values  into  registers,  the  optimization  had  a  net  savings 
of  five  words  (ten  instructions)  of  code  without  significantly  affecting  the  method's  running 
time. 

Statement  Postprocessor 

The  Statement  Postprocessor  performs  transformations  and  optimizations  specific  to  the 
idiosyncrasies  of  the  MDP  architecture.  These  tasks  were  separated  from  the  Statement 
Optimizer  to  allow  the  output  of  the  Statement  Optimizer  to  be  converted  back  into  I-Code 
before  the  Statement  Postprocessor's  MDP-specific  transformations  are  done. 

The  Statement  Postprocessor’s  tasks  are  shown  in  Figure  5-4  and  outlined  below. 

Primitive  Splitter 

Concurrent  Smalltalk  defines  certain  associative  primitive  methods  (+,  *,  max,  min,  and,  or, 
xor,  logand,  logor,  and  logxor)  to  take  an  arbitrary  number  of  arguments,  while  the  MDP 
only  provides  instructions  for  operating  on  two  arguments  at  a  time.  Therefore,  each 
primitive  that  takes  more  than  two  arguments  has  to  be  converted  into  a  sequence  of 
primitives  of  two  arguments.  This  is  the  function  performed  by  the  Primitive  Splitter.  It 
scans  the  sfmtgraph  and  splits  all  primitives  taking  more  than  two  arguments  into  sequences 
of  shorter  primitives,  creating  temporary  variables  to  hold  the  intermediate  values.  The 
order  in  which  the  parentheses  are  placed  in  a  split  is  not  specified  in  Concurrent  Smalltalk. 
Currently  the  compiler  evaluates  (op  a  b  c  d  z)  as  if  it  were  (op  ...  (op  (op  (op  a 
b)  c)  d)  ...  z)  when  op  is  a  primitive.  This  order  minimizes  the  code  size;  nevertheless, 
the  placement  of  parentheses  can  be  easily  changed  to  evaluate  op  in  a  tree  structure  if  this 
is  desirable. 
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Postprocessed  Stmtgraph 

Figure  5-4.  Statement  Postprocessor  Block  Diagram. 

Tha  transformations  and  optimizations  dons  by  the  Statement  Postprocessor  are  mostly  MDP-spe- 
dfic  and  done  only  once. 

Instance  Variable  Csand  Transformer 

Due  to  a  current  idiosyncrasy  of  the  operating  system,  the  target  of  a  csend  can  only  be  a 
local  variable.  The  Front  End  and  the  Statement  Optimizer  are  not  aware  of  this  restriction, 
however,  and  they  generate  csend  statements  with  instance  variables  as  targets.  The 
Instance  Variable  Csend  Transformer  converts  all  such  csends  into  csends  with  temporary 
local  variables  as  targets  followed  by  moves  into  appropriate  instance  variables. 

Primitive  Optimizer 

The  Primitive  Optimizer  performs  one  final  pass  at  optimization  of  primitives.  It  differs  from 
the  Constant  Folder  in  that  it  performs  MDP-specific  optimizations.  The  two  optimizations  it 
currently  performs  are  converting  multiplications  and  divisions  by  powers  of  two  into 
arithmetic  shifts. 

Statement  Printer 

A  routine,  '-stmtgraph,  is  provided  to  print  a  stmtgraph  in  an  I-Code-like  format.  The 
routine  is  i  jr  debugging  purposes,  but  it  can  also  be  used  to  convert  a  stmtgraph  back 

into  a  variant  of  I-Code.  Output-stmtgraph  prints  only  the  operation,  target,  method,  and 
arguments  of  the  stmts,  ignoring  the  other  fields  used  by  the  Statement  Analyzer  and 
Optimizer.  Output-stmtgraph  contains  an  algorithm  similar  to  that  of  the  Assembly  Code 
Generator's  Branch  Inserter  for  inserting  unconditional  branches  and  labels  in  before 
statements  that  are  targets  of  branches  into  the  printed  I-Code.  This  routine  produced  some 
of  the  listings  in  Chapter  8. 
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The  Instruction  Generator  converts  the  stmtgraph  into  a  module,  which  is  an  ordered  digraph 
of  MDP  assembly  language  instructions.  In  order  to  perform  this  function,  the  Instruction 
Generator  has  to  find  an  appropriate  order  for  the  statements  in  the  stmtgraph  as  well  as 
allocate  the  local  variables  in  the  stmtgraph  into  either  registers  or  memory  locations.  These 
functions  are  performed  by  the  Linearizer  and  the  Variable  Allocator.  The  Variable  Allocator 
creates  a  varinfo  record  that  describes  the  final  assignments  of  variables  to  locations  as  well 
as  some  statistics  about  the  stmtgraph.  After  the  order  of  statements  and  the  locations  of  the 
variables  are  known,  the  actual  generation  of  instructions  (insts)  can  begin.  The  Stmt 
Compiler  uses  the  Frame  Handler  to  keep  track  of  the  data  in  the  registers  and  memory 
locations  while  it  is  generating  the  instructions. 


Insts 

(defstruct  (inst  (-.include  dinode)  (print-function  print-inst)) 
label  ;The  label  number  for  this  instruction, 
op 
srcl 
src2 
dst 

reads  ;Map  of  registers  whose  values  are  used  by  this  instruction. 

writes  ;Map  of  registers  written  or  trashed  by  this  instruction. 

live  ;Map  of  registers  live  at  the  end  of  this  instruction. 

vlive  ;Map  of  vlocs  live  at  the  end  of  this  instruction. 

pc  ;The  program  counter  in  half-words. 

next  ;The  next  instruction  in  the  output  code  or  NIL  if  there  is  none. 

prev)  ;The  previous  instruction  in  the  output  code  or  NIL  if  there  is  none. 

An  inst  record  describes  an  MDP  assembly  language  instruction.  The  instruction  has  an 
operand  op,  up  to  two  source  locations  srcl  and  src2,  and  a  destination  location  dst.  These 
fields  are  enough  to  completely  describe  the  instruction.  Please  refer  to  Appendix  A  for 
details  on  the  MDP  instruction  set.  The  remaining  fields  contain  additional  data  about  the 
instruction  such  as  the  registers  read  and  written  by  the  instruction,  the  context  variables 
live  at  the  end  of  the  instruction,  the  address  of  the  instruction,  and  links  to  the  previous  and 
next  instruction  in  the  method  code  (these  links  are  static  code  location  links  as  opposed  to 
the  flow  of  control  links  that  are  edges  of  the  stmt  and  inst  digraphs). 

The  possible  locations  that  may  be  used  as  the  srcl ,  src2,  or  dst  fields  of  an  instruction  are 
listed  in  Table  6-1. 


Table  6-1.  Location  Syntax 


(3const  <constant>) 
dconst  <constant>) 
(reg  <number>) 
(areg  <number>) 
(sreg  <name>) 
(vioc  <number>> 
(Hoc  <number>) 
(aloe  <number>) 
(rei) 


Short  constant  (one  that  can  be  generated  by  an  MDP  addressing  mode). 
Long  constant  (one  that  requires  a  dc  instruction). 

MDP  data  register  ro,  ri,  R2,  or  R3. 

MDP  address  register  ao,  ai,  a2,  or  A3. 

MDP  special  register  <name>. 

Context  variable  at  offset  <number>. 

Instance  variable  at  offset  <number>  in  the  instance  object 
Argument  at  offset  <number>  in  the  message. 

Filer  for  branch  addressing  mode  (see  Assembly  Code  Generator). 
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Ordered  Stmtgraph  Varinfo 


Frame 


Inst  Module 

Figure  6-1.  Instruction  Generator  Block  Diagram. 

Linearizer 

The  Linearizer  calls  the  finearize  function  (see  Appendix  C)  of  the  digraph  Utilities  to  produce 
an  ordering  of  the  Stmtgraph's  nodes  that  tries  to  minimize  the  number  and  total  length  of 
branches  in  the  stmtgraph.  The  statements  are  compiled  into  insts  in  that  order,  so  the  static 
links  (the  prev  and  next  fields  of  insts)  between  the  instructions  in  the  module  will  reflect  the 
order  on  statements  in  the  stmtgraph  defined  by  finearize. 

Variable  Allocator 

The  Variable  Allocator  calculates  some  statistics  about  the  stmtgraph  and  assigns  all  local 
variables  that  are  used  into  either  registers  or  context  locations.  The  assignment  process 
proceeds  by  first  finding  all  local  variables  that  are  actually  referenced  in  the  stmtgraph.  Due 
to  the  statement  optimizations  such  as  the  Move  Eliminator,  many  local  variables  are 
actually  never  referenced.  The  referenced-vars  function  returns  a  bmap  of  all  variables  that 
are  used  in  the  stmtgraph. 

The  bmap  of  referenced  variables  is  then  passed  to  the  Register  Allocator  which  attempts  to 
place  as  many  variables  as  possible  into  registers.  It  reports  which  variables  it  was  able  to 
put  into  registers;  the  remaining  ones  are  passed  to  the  Context  Variable  Allocator,  which 
packs  them  as  tightly  as  it  can  into  context  slots.  The  outputs  of  both  Allocators  are  stored 
into  a  varinfo  record  that  lists  the  location  of  each  local  variable  and  whether  a  context  is 
necessary  or  not 
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Varinfo 


Figure  6-2.  Variable  Allocator  Block  Diagram. 

Register  Allocator 

The  Register  Allocator  tries  to  allocate  local  variables  in  the  MDFs  registers.  Since  variables 
that  are  targets  of  c  sends  must  be  in  memory,  they  are  ineligible  for  register  allocation  and 
immediately  disqualified.  The  other  variables  are  either  always  in  the  context  in  memory  or 
always  in  a  register.  No  attempt  is  made  to  keep  a  variable  in  a  register  for  a  portion  of  its 
lifetime  and  in  memory  for  the  rest  of  its  lifetime,  although  some  of  the  frame  optimizations 
done  by  the  Stmt  Compiler  and  Frame  Handler  may  have  this  effect. 

The  variables  eligible  for  register  allocation  are  prioritized  according  to  the  formula 

nrefs 

Priority  ”  max(nrefs,nSve) 

where  nrefs  is  the  number  of  references  to  the  variable  present  in  the  stmtgraph  and  nlive  is 
the  number  of  statements  during  which  the  variable  is  live.  The  highest  priority  variables 
are  considered  first.  The  effect  of  this  system  of  priorities  is  to  make  variables  that  are  used 
often  and  have  short  lifetimes  be  more  likely  to  be  allocated  in  registers  than  variables  that 
are  used  rarely  and  have  long  lifetimes.  The  former  variables  use  little  time  in  registers,  so 
considering  them  first  greatly  increases  the  number  of  variables  that  will  fit  in  the  registers. 
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Unallocated  Variables 

Figure  6-3.  Register  Allocator  Block  Diagram. 

The  Register  Allocator  needs  to  know  how  many  registers  it  can  allocate.  The  Stmt  Compiler 
needs  temporary  registers  to  compile  some  statements,  so  the  Register  Allocator  contains  a 
function,  the  Register  Requirements  Calculator,  that  yields  an  estimate  of  how  many 
temporary  registers  are  required  to  compile  each  statement  in  the  stmtgraph.  Since  compiling 
some  statements  requires  the  use  of  registers  with  specific  numbers  (for  example,  some 
statements  make  system  calls  that  require  an  argument  in  Rl),  each  estimate  includes  both 
the  maximum  number  of  temporary  registers  needed  to  compile  the  statement  and  the 
specific  register  numbers  to  be  allocated  for  the  statement.  The  estimates  are  always 
conservative  to  prevent  the  Stmt  Compiler  from  running  out  of  registers,  as  once  a  variable 
has  been  assigned  to  a  register,  there  is  no  way  to  undo  that  assignment. 

Once  the  variables  have  been  prioritized  and  the  amount  of  space  available  in  the  registers  is 
known,  the  assignment  process  begins.  A  greedy  algorithm  is  used.  The  variables  are 
considered  in  order  of  decreasing  priority.  For  each  variable,  the  Allocator  considers  each 
statement  in  which  the  variable  is  live.  If  there  is  a  common  free  register  in  all  such 
statements,  the  variable  is  assigned  to  that  register,  and  that  register  is  marked  as  busy. 
Regardless  of  whether  the  variable  was  assigned  or  not,  the  variable  with  the  next  lowest 
priority  is  considered  until  all  variables  have  been  considered.  The  variables  which  were  not 
allocated  to  registers  are  then  passed  to  the  Context  Variable  Allocator. 

In  practice,  despite  the  low  number  of  registers  on  the  MDP,  the  Register  Allocator  is  able  to 
allocate  almost  all  variables  to  the  registers.  The  vast  majority  of  variables  are  temporaries 
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with  one-instruction  lifetimes,  giving  them  maximum  priority,  and  all  such  variables  can  be 
allocated  to  registers.  Only  a  few  remain  to  be  processed  by  the  Context  Variable  Allocator. 

Context  Variable  Allocator 

Unallocated  Variables 


Stmtgraph 


Interference  Matrix 


Varinfo 


Figure  6-4.  Context  Variable  Allocator  Block  Diagram. 

The  Context  Variable  Allocator  is  a  procedure  in  the  Optimist  compiler  that  is  not  often  found 
in  other  compilers.  The  Context  Variable  Allocator's  goal  is  packing  the  few  remaining 
unallocated  variables  into  as  few  context  slots  as  possible.  Context  space  is  very  limited 
because  the  MDP  is  only  capable  of  directly  addressing  the  first  sixteen  words  of  a  context 
and  the  operating  system  reserves  five  of  them,  leaving  only  eleven  for  storage  of  local 
variables;  thus,  context  local  variables  must  be  conserved. 

The  Context  Variable  Allocator  works  by  calculating  an  interference  matrix  of  the  unallocated 
variables.  The  interference  matrix  is  a  two-dimensional  Boolean  matrix  that  indicates 
whether  any  two  given  variables  are  ever  simultaneously  live  at  any  point  in  the  stmtgraph. 
If  so,  then  the  variables  interfere  and  cannot  be  assigned  to  the  same  context  location. 

The  interference  matrix  is  passed  to  a  general  graph  coloring  algorithm  that  tries  to  color  the 
graph  represented  by  the  matrix  (each  variable  is  a  vertex,  and  two  variables  are  connected 
by  an  edge  iff  they  interfere)  with  as  few  colors  as  possible  (the  colors  represent  context 
memory  locations)  so  that  no  two  vertices  with  the  same  color  are  connected  by  an  edge.  In 
general  this  problem  is  NP-complete,  but  a  good  heuristic  for  solving  it  exists  [4]. 

The  main  insight  is  to  note  that  if  an  n-coloring  of  the  graph  exists  and  the  graph  contains  a 
vertex  A  with  degree  less  than  n,  then  A  can  be  removed  from  the  graph,  the  new  graph  n- 
colored,  and  then  A  assigned  a  color  different  from  any  of  its  (at  most  n- 1)  neighbors.  Since  n 
is  initially  not  known,  the  Optimist’s  coloring  algorithm  assumes  that  n  is  1  until  it  can 
remove  no  more  vertices  with  degree  0  and  still  has  a  nonempty  graph  left.  At  that  point  it 
revises  its  estimate  of  n  to  2  and  proceeds  to  remove  all  vertices  with  degrees  0  and  1.  Note 
that  n  is  often  less  than  the  maximum  degree  of  a  vertex  in  the  original  graph  because 
removing  vertices  often  lowers  other  vertices’  degrees. 
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One  final  improvement  in  the  coloring  algorithm  exists  in  the  phase  in  which  vertices  are 
assigned  colors  after  having  been  removed  from  the  graph.  At  that  point  the  algorithm  tries 
to  avoid  new  colors  as  long  as  possible,  preferring  to  color  vertices  that  are  being  put  back 
into  the  graph  with  colors  that  were  already  used.  Sometimes  this  will  yield  a  better  coloring 
of  the  graph  than  n  would  indicate.  The  simplest  example  of  this  phenomenon  is  the  graph 
composed  of  the  four  vertices  of  a  square — the  algorithm  will  able  to  2-color  the  graph  even 
though  it  will  reach  an  estimate  n  of  3. 

In  all  of  the  practical  cases  that  I  have  encountered  so  far,  the  Context  Variable  Allocator 
always  yielded  an  optimal  allocation  of  variables  to  context  slots. 

Stmt  Compiler 

The  Stmt  Compiler  compiles  each  stmt  in  the  stmtgraph  into  a  number  of  MDP  instructions. 
The  Utilities  function  map-digraph  is  used  to  construct  the  module.  While  the  Stmt  Compiler 
is  compiling  each  statement,  the  Frame  Handler  keeps  track  of  the  state  of  the  variables. 

The  Stmt  Compiler  is  too  long  to  describe  in  detail  here;  instead,  only  the  highlights  will  be 
presented  below.  Please  see  Appendix  D  for  the  details  about  the  implementation  of  the  Stmt 
Compiler. 

Frame  Handler 

The  Frame  Handler  works  with  a  data  structure  called  a  frame: 

(defstruct  (frame  ('.copier  copy-framel )) 
varinfo  , -Global  varinfo  assignments. 

(regs  (make-array  '(4)))  Array  of  known  register  slot  values. 

(lockmap  bO  type  bmap)  ;Bmap  of  register  locks. 

(waiting  bO  type  bmap)  ;Bmap  of  unforced  slots. 

(migrate  t)  .True  if  the  instance  object  could  have  migrated  away. 

(Iru-regs  ’(0  1  2  3)))  .List  of  registers  in  order  from  most  to  least  recently  used. 

The  frame  contains  the  entire  state  of  the  variables  at  some  place  in  the  stmtgraph.  The  Stmt 
Compiler  is  able  to  interrogate  the  frame  about  the  location  of  a  specific  local  variable, 
whether  a  variable's  value  is  available,  and  whether  the  instance  object  could  have  migrated 
away  to  another  node  (which  it  can  whenever  there  is  an  opportunity  to  suspend  execution  of 
the  method).  The  Frame  Handler  knows  about  the  Variable  Allocator's  assignments  through 
the  varinfo  record.  In  addition,  it  also  keeps  track  of  the  current  values  in  the  registers;  if  the 
Stmt  Compiler  requests  an  access  to  a  context  variable  but  whose  value  just  happens  to  be 
present  in  a  register,  the  Frame  Handler  will  return  the  register  to  the  Stmt  Compiler.  The 
Frame  Handler  also  is  in  charge  of  allocating  free  registers  for  temporary  use  by  the  Stmt 
Compiler;  it  uses  the  least  recently  used  strategy  to  allocate  these  temporaries  and  avoids 
allocating  registers  that  contain  variables.  Finally,  the  Stmt  Compiler  can  ask  the  Frame 
Handler  to  lock  a  certain  register,  preventing  it  from  being  allocated,  and  the  Frame  Handler 
will  honor  that  request. 

The  frame  contains  a  significant  amount  of  data  outlined  above  in  addition  the  varinfo  record. 
Since  the  instructions  are  usually  generated  in  the  order  in  which  they  are  executed,  such 
data  can  be  maintained  and  be  useful.  Problems  do  arise,  though,  when  a  join  is  encountered 
in  the  stmtgraph.  In  that  case  the  Frame  Handler  compares  the  two  or  more  frames  in  the 
joining  paths  and  picks  the  most  conservative  frame  out  of  the  two  or  more — i.e.  if  the  frames 
disagree  about  what  is  in  register  Rl,  the  resulting  frame  will  contain  no  information  about 
the  contents  of  Rl.  Also,  if  one  of  the  frames  of  the  joining  paths  is  unavailable  (because,  say, 
that  section  of  code  has  not  yet  been  compiled  due  to  a  loop),  the  Frame  Handler  selects  the 
most  conservative  frame  possible  which  contains  only  the  information  from  the  varinfo  record. 
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Issues  in  Compiling  Statements 

The  Stmt  Compiler,  for  its  part,  tries  to  be  as  cooperative  with  the  Frame  Handler  as  possible. 
It  lets  the  Frame  Handler  examine  every  instruction  that  it  generates  so  that  the  Frame 
Handler  always  has  a  current  idea  of  what  values  are  in  what  registers;  if  the  Stmt  Compiler 
ever  neglected  to  tell  the  Frame  Handler  about  a  change  to  a  register,  the  frame  would 
become  obsolete  with  potentially  disastrous  results.  The  process  of  updating  the  frame  has 
been  made  very  simple  and  mechanical  to  try  to  avoid  this  kind  of  error. 

The  Stmt  Compiler  also  helps  the  Frame  Handler  by  pointing  out  possible  aliases  in  the  code 
it  generates.  For  example,  when  the  Stmt  Compiler  outputs  a  move  instruction,  it  informs  the 
Frame  Handler  that  the  source  and  destination  locations  are  temporarily  aliases  of  each 
other  until  one  of  them  is  changed.  The  Frame  Handler  keeps  track  of  such  aliases,  and,  if  a 
location  is  requested  but  its  alias  can  be  accessed  easier,  it  will  return  the  alias. 

Uninterruptibility  of  Sends 

The  Stmt  Compiler  uses  the  Frame  Handler's  special  services  for  compiling  some  statements. 
A  major  issue  in  designing  the  Stmt  Compiler  was  preventing  faults  in  the  middle  of  csend, 
rsend,  and  reply  statements.  Due  to  the  design  of  the  MDP,  once  the  first  word  of  a 
message  has  been  sent  onto  the  network  by  one  of  these  statements,  sending  must  continue 
uninterrupted  until  the  entire  message  has  been  sent.  A  fault  caused  by  accessing  a  context 
variable  with  an  unavailable  value  would  crash  the  system.  An  access  of  the  instance  object 
when  it  has  migrated  away  to  another  node  would  have  similar  consequences.  To  avoid  these 
difficulties,  the  Stmt  Compiler  checks  each  slot  that  is  going  to  be  sent  in  csend,  rsend,  and 
reply  statements.  If  that  slot  is  not  guaranteed  to  be  available,  the  Stmt  Compiler  issues  a 
statement  to  touch  that  slot  before  sending  begins.  Since  most  of  the  time  values  can  be 
shown  to  be  available,  having  the  Frame  Handler  keep  track  of  the  availability  data  saves  a 
lot  of  unnecessary  code. 

Preventing  Limbo  Variables 

There  is  another  unobvious  issue  in  the  design  of  the  Stmt  Compiler.  Consider  the  code  in 
Figure  6-5a.  This  pair  of  csend  statements  illustrates  a  problem  that  could  arise  in  the  code 
generated  by  the  compiler  if  the  compiler  were  not  very  careful.  When  two  consecutive  stores 
are  made  to  a  variable,  the  first  of  which  makes  the  variable's  value  unavailable,  the  variable 
enters  the  limbo  state.  There  is  no  way  to  tell  when  the  value  of  a  limbo  variable  might 
change,  and  that  variable  is  for  all  practical  purposes  useless  from  that  point  on.  The 
compiler  does  not  let  variables  enter  the  limbo  state  by  touching  a  variable  before  a  store  to  it 
whenever  the  variable's  value  is  not  guaranteed  to  be  available. 

Deallocating  Variables 

On  a  similar  note,  the  compiler  issues  code  to  touch  all  context  variables  whose  values  are  not 
guaranteed  to  be  available  just  before  the  context  is  deallocated.  This  forces  the  method  to 
wait  until  all  replies  come  back  before  the  context  can  be  freed.  Without  this  precaution,  a 
reply  could  come  back  after  the  context  has  been  deallocated  and  reused  for  another  method, 
clobbering  another  method's  variables. 

The  touch  operations  are  done  after  the  method  has  sent  its  reply  to  its  caller,  so  even  if  a 
touch  causes  a  wait,  that  wait  does  not  slow  down  the  program  that  is  running  because  the 
reply  has  already  been  sent  to  the  caller.  The  only  externally  visible  effect  is  that  the  context 
remains  allocated  for  a  somewhat  longer  time  than  it  would  otherwise  have  been. 
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Figure  6-5.  The  Peril  of  Limbo  Variables. 

A  variable  enters  the  limbo  state  when  two  csends  (or  a  csend  followed  by  any  store)  are  made  to  it 
without  touching  it  in  between.  Sample  code  that  might  cause  the  situation  is  shown  in  (a).  Actu¬ 
ally.  due  to  the  optimizations  in  the  Statement  Optimizer,  the  first  csend  in  (a)  would  be  optimized  to 
a  nil  target,  eliminating  the  problem,  but  the  problem  could  still  be  made  to  appear  in  a  more  com¬ 
plicated  example  lire  (b)  where  test  is  always  false  but  the  compiler  does  not  know  that. 

The  problem  with  a  variable  in  the  limbo  state  is  that  its  value  might  change  at  any  time  without 
warning,  (c)  shows  what  might  happens  when  a  variable  a  is  in  limbo.  After  both  csends  are  sent, 
the  value  of  a  is  unavailable.  The  move  from  a  to  b  correctly  waits  until  the  value  of  a  is  available; 
let's  say  that  beta  replies  first,  so  the  value  of  a  becomes  (beta  x) .  The  move  then  proceeds,  and 
everything  is  fine  until  the  reply  from  alpha  comes  back,  at  which  point  it  clobbers  the  value  of  a 
without  any  warning.  When  a  is  in  limbo,  there  is  no  way  to  tell  whether  alpha  (or  beta)  has  re¬ 
turned  its  value  or  not. 

The  only  good  way  of  dealing  with  limbo  variables  is  to  make  sure  that  they  don't  arise.  An  appar¬ 
ent  alternative,  checking  whether  the  value  of  the  variable  is  unavailable  at  the  time  a  called  method 
responds,  will  not  work.  In  the  above  example  the  compiler  would  touch  a  between  the  two  csends 
to  make  sure  it  does  not  enter  the  limbo  state. 
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Context  Optimization 

When  there  are  no  context  variables,  the  Stmt  Compiler  does  not  compile  the  operating 

system  calls  to  allocate  a  context  at  the  beginning  of  the  method  and  deallocate  it  at  the  end,  | 

resulting  in  a  significant  speed  improvement  for  the  method  as  well  as  a  small  (three 

instruction)  space  improvement.  Similarly,  if  there  are  no  references  to  the  instance  object  in 

the  method,  then  no  code  is  generated  to  get  the  address  of  the  instance  object  into  register 

A2,  resulting  in  a  small  speed  increase  and  space  saving. 


| 


33 


Chapter  7.  Assembly  Code  Generator 


Inst  Module 


Assembly  Code 


Figure  7-1.  Assembly  Code  Generator  Diagram. 

The  Assembly  Code  Generator  performs  transformations  and  optimizations  on  the  module 
created  by  the  Instruction  Generator.  Since  the  Instruction  Generator  relied  on  the  module 
topology  to  indicate  paths  of  control  flow,  the  Branch  Inserter  has  to  insert  branches  into  the 
module.  The  Variable  Initializer  initializes  selected  context  variables  where  appropriate.  The 
Peep-Hole  Optimizer  performs  several  instruction  optimizations  such  as  shifting  instructions 
to  align  DC  instructions  to  word  boundaries  and  combining  SEND  and  sende  instructions  into 
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SEND 2  and  SEND2E.  In  conjunction  with  the  Peep-Hole  Optimizer,  the  Long  Branch  Handler 
extends  short  branches  that  do  not  reach  their  destinations  into  long  branches,  which  is  a 
nontrivial  operation  on  the  MDP  because  long  branches  require  the  use  of  register  RO,  while 
short  branches  do  not  Finally,  the  Instruction  Printer  outputs  the  module  into  a  file  as  a 
series  of  assembly  language  statements. 

Branch  Inserter 

The  Branch  Inserter  scans  the  stmtgraph  and  finds  all  places  where  control  flow  does  not 
simply  pass  from  one  instruction  to  the  next  It  inserts  unconditional  branches  in  all  places 
where  the  successor  of  an  instruction  according  to  the  digraph  is  not  the  next  instruction  in 
the  static  sequence.  Conditions  are  also  considered;  if  one  successor  of  a  condition  is  the 
next  instruction  in  the  static  sequence,  the  condition  is  made  into  a  conditional  branch 
(possibly  reversing  the  condition).  If  neither  successor  is  the  next  instruction  in  the  static 
sequence,  a  conditional  branch  is  made,  followed  by  an  unconditional  branch. 

Variable  Initializer 


Figure  7-2.  The  Need  for  the  Variable  Initializer. 

The  method  in  (a)  compiles  to  the  code  sketched  in  (b).  The  Stmt  Compiler  inserts  the  touch  in¬ 
struction  before  the  second  cset  to  a  to  avoid  the  possibility  of  a  going  into  the  limbo  state  (see 
Figure  6-5);  the  Stmt  Compiler  does  not  realize  that  the  two  csets  to  a  could  never  both  be  exe¬ 
cuted  (and  even  H  it  did,  other  pathological  examples  could  be  constructed). 

Thus,  when  test  is  false,  an  uninitialized  a  would  be  referenced  by  the  touch  instruction,  even 
though  the  source  program  never  references  an  uninitialized  variable.  Since  referencing  uninitial¬ 
ized  memory  is  dangerous  (because  that  memory  may  contain  the  unavailable  value,  causing  the 
method  to  wait  forever),  the  compiler  is  under  an  obligation  to  initialize  a. 
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The  Variable  Initializer  inserts  code  to  store  Nl  L  in  any  context  variables  that  are  live  at  the 
beginning  of  the  method.  The  Variable  Initializer  is  not  intended  to  provide  a  default  initial 
value  for  the  method's  local  variables;  in  fact,  it  does  not  initialize  register  variables.  Instead, 
the  Variable  Initializer  is  necessary  to  handle  some  pathological  eases  in  which  the  extra 
touches  put  in  by  the  Stmt  Compiler  to  prevent  Limbo  Variables  can  refer  to  uninitialized 
variables.  Touching  an  uninitialized  variable  is  dangerous  because  that  variable  just  might 
happen  to  have  the  unavailable  value,  causing  the  method  to  hang.  See  Figure  7-2  for  an 
example  in  which  the  source  code  does  not  refer  to  any  uninitialized  variables  yet  in  which  an 
uninitialized  variable  reference  is  created  by  the  Limbo  Variable  elimination  process. 

Peep-Hole  Optimizer 

The  Peep-Hole  Optimizer  currently  performs  two  transformations:  combining  sends  and 
aligning  DCs.  In  addition,  it  includes  the  PC  Scanner,  a  routine  that  finds  the  address  of  each 
instruction  in  the  module.  The  DC  Aligner  is  actually  combined  with  the  PC  Scanner  to 
improve  efficiency;  this  combination  is  not  essential  to  the  algorithms,  though,  and  the  two 
functions  will  be  explained  separately. 

send  Combiner 

The  Instruction  Optimizer  first  tries  to  combine  send  and  SENDE  instructions  into  SEND2s 
and  SEND2ES,  which  send  two  values  instead  of  just  one  (see  Appendix  A).  It  scans  the 
module  and  considers  every  send  and  SENDE  instruction.  It  scans  backwards  from  that 
instruction  until  the  beginning  of  its  basic  block  for  another  SEND  instruction.  If  it  finds  one, 
it  checks  whether  the  instructions  between  the  SEND  instruction  and  the  SEND  or  SENDE  can 
all  be  moved  either  before  the  leading  SEND  or  after  the  trailing  send  or  sende.  It  uses  a 
utility  subroutine,  insts-commute?,  to  test  whether  one  instruction  can  be  moved  past  another 
without  affecting  the  semantics  of  the  program.  Insts-commute?  considers  such  factors  as 
whether  one  instruction  changes  a  register  used  by  the  other,  whether  one  can  change  the 
flow  of  control,  and  whether  they  both  use  the  same  resource  such  as  the  network  or  the 
stack.  If  all  instructions  between  the  SEND  and  the  SEND  or  sende  can  be  moved  out,  all  of 
these  instructions  are,  in  fact,  moved  out  of  that  interval,  and  the  send  is  combined  with  the 
SEND  or  SENDE  to  make  a  SEND2  or  SEND2E  instruction.  The  process  continues  until  no  more 
such  combinations  can  be  made. 

DC  Aligner 

DC  instructions  are  constants  embedded  in  the  method  code.  When  the  MDP  attempts  to 
execute  a  constant,  it  just  loads  it  into  register  RO  and  proceeds  with  the  next  instruction. 
Normally  two  instructions  can  fit  into  a  word,  but  constants  must  be  word-aligned,  which 
forces  the  MDPSim  assembler  to  issue  a  no-operation  instruction  if  the  PC  was  not  word- 
aligned.  The  objective  of  the  DC  Aligner  is  to  try  to  align  as  many  DCs  as  possible  to  word 
boundaries  to  prevent  wasted  code  and  time. 

The  DC  Aligner  looks  for  DC  instructions  at  mid-word  addresses.  If  it  finds  one,  it  tries  to 
shift  it  to  a  word  boundary  by  exchanging  it  with  either  the  previous  or  the  next  instruction 
using  insts-commute?  to  test  whether  such  an  exchange  would  be  legal.  If  the  exchange  can 
be  done,  it  is  done.  Otherwise,  the  DC  instruction  is  left  as  is;  the  assembler  will 
automatically  align  the  DC. 

PC  Scanner 

The  PC  Scanner  scans  through  the  module  advancing  the  PC  by  one  instruction  (1/2  word)  for 
each  instruction  except  DCs  which  are  one  word  (two  instructions)  long.  It  aligns  the  PC  to  a 
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word  boundary  at  every  DC  and  every  instruction  that  is  a  destination  of  a  branch  (branches 
can  only  branch  to  word  boundaries). 

Long  Branch  Handler 

The  Long  Branch  Handler  is  the  most  complicated  routine  in  the  Assembly  Code  Generator. 
It  scans  the  module  and  checks  every  short  branch  it  finds  to  make  sure  that  it  can  reach  its 
destination  within  the  limited  MDP  branching  range  (-15  to  +16  words).  It  uses  several 
heuristics  to  try  to  extend  short  branches  that  do  not  reach  their  destinations  into  long 
branches. 

The  first  heuristic  tried  is  branch  chaining  (Figure  7-3a)  [13].  When  considering  a  short 
branch  that  does  not  reach  the  destination,  the  Long  Branch  Handler  checks  whether  there  is 
any  other  branch  instruction  in  the  module  that  branches  to  the  same  destination,  and,  if  so, 
whether  that  branch  is  within  the  short  branching  range  of  the  current  location.  Such  a 
check  can  easily  be  done  by  checking  the  destination  instruction's  predecessors  in  the  inst 
digraph.  If  the  check  succeeds,  the  destination  of  the  branch  is  changed  to  point  to  the  other 
branch  that  does  reach  the  destination. 

If  the  above  heuristic  fails  and  the  branch  is  an  unconditional  one,  the  branch  is  changed  to  a 
DC/br  RO  instruction  sequence  (Figure  7-3b).  This  instruction  sequence  uses  the  RO 
register,  while  the  short  branch  does  not;  thus,  in  order  to  avoid  generating  bad  code,  the 
Long  Branch  Handler  checks  that  register  RO  is  not  live  at  the  point  of  the  branch 
instruction.  If  RO  is  live,  the  Long  Branch  Handler  gives  up  and  signals  an  error.  It  is  the 
Instruction  Generator's  duty  to  make  sure  that  RO  is  not  live  at  any  point  at  which  an  un¬ 
conditional  long  branch  could  appear;  this  is  why  the  linearization  is  done  before  the  Stmt 
Compiler  compiles  the  statements  into  instructions. 

If  the  branch  is  conditional,  the  Long  Branch  Handler  checks  whether  it  is  followed  by  a  short 
unconditional  branch.  If  so,  the  condition  is  reversed  and  the  two  destination  addresses 
interchanged,  reducing  the  problem  to  extending  an  unconditional  branch  (Figure  7-3c).  This 
situation  is  handled  as  above.  There  is  a  possibility  that  interchanging  the  two  destination 
addresses  overflows  the  range  of  the  short  branch.  If  this  happens,  the  overflow  will  be 
handled  on  the  next  pass  of  the  Long  Branch  Handler. 

If  the  branch  is  conditional  and  not  followed  by  an  unconditional  short  branch,  the  source 
register  for  the  condition  is  considered.  If  it  is  not  RO,  the  branch  is  changed  into  a  DC  /  br 
Rn,  RO  instruction  sequence  in  a  similar  manner  as  above  (Figure  7-3d).  If  the  condition 
register  is  RO,  the  Long  Branch  Handler  attempts  to  move  the  condition  to  some  other 
register  that  is  not  live.  If  it  is  successful,  the  case  is  handled  as  before  (Figure  7-3e).  If  not, 
the  branch  is  changed  to  a  short  branch  around  a  long  unconditional  branch  instruction 
(Figure  7-3f). 

In  several  of  the  above  cases  an  extra  DC  instruction  is  introduced  into  the  module.  The  DC 
Aligner  is  run  after  the  Long  Branch  Extender  to  try  to  align  these  DCs  to  word  boundaries. 
The  DC  Aligner  and  the  Long  Branch  Extender  are  run  repeatedly  until  neither  makes  any 
changes  to  the  module.  It  can  be  shown  that  these  two  handlers  will  not  continue  to  modify 
the  module  indefinitely. 

Instruction  Printer 

The  Instruction  Printer  is  the  final  stage  of  the  Optimist  compiler.  It  prints  the  MDP 
assembly  language  instructions  in  the  module  onto  a  stream.  It  outputs  the  entire  module  as 
a  CODE  message,  the  format  of  which  is  defined  in  Appendix  B.  Before  outputting  the 
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module,  it  scans  the  entire  module  and  places  labels  on  statements  that  are  destinations  of 
branches;  the  branches  then  refer  to  these  labels  instead  of  less  readable  numeric  offsets. 
Please  refer  to  [10]  and  [9]  for  the  complete  syntax  of  the  assembly  language.  Chapter  8 
contains  sample  outputs  of  the  Instruction  Printer. 


BR  L003 
BR  L003 


L003: 

(a) 


BR  L005 
L005 :  BR  LOO  3 
L003 :  I 


(b) 


BR  L003 


DC  L003-<*+2) 
BR  R0 


(C) 

BF  R0, L003 
BR  LOO 4 

=> 

BT  RO, L004 

BR  L003 

(Use  method  (b)  next) 

(d) 

BF  Rl,  LOO 3 

- 

DC  L003- (*+2) 
BF  Rl, RO 

(e) 

I  RO 

BF  RO, L003 

I  ...Rl 

BF  Rl,  L003 

(Use  method  (d)  next) 

(f) 

BF  RO,  LOO 3 

=> 

BT  R0.L005 

BR  L003 

(Use  method  (b)  next) 

Figure  7-3.  Expanding  Branches. 

There  are  seven  methods  of  extending  short  branches  into  long  ones.  These  methods  are  outlined 
above.  In  each  situation  the  overflowing  short  branch  is  in  italics.  The  methods  are  branch  chain¬ 
ing  (a),  simple-extending  an  unconditional  branch  (b),  reversing  a  conditional  branch  (c).  simple-ex¬ 
tending  a  conditional  branch  (d).  changing  the  condition  register  (e),  and  branching  around  an  un¬ 
conditional  branch  (f). 
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Below  is  an  example  of  a  typical  small  Concurrent  Smalltalk  method  and  the  stages  of  its 
compilations.  The  example  was  intended  to  be  simple,  illustrative,  useful,  and  typical;  it  was 
not  contrived  to  exhibit  the  compiler's  best  performance,  nor  does  it  invoke  all  of  the 
compiler's  optimisations. 

The  source  Concurrent  Smalltalk  method  is  shown  in  Figure  8-1.  The  method  belongs  to  the 
class  pair,  also  illustrated  in  Figure  8-1. 

(class  pair  (object)  car  cdr) 

(method  pair  lengthl  (n)  () 

(if  (eq  odr  'nil) 

(tin) 

(lengthl  cdr  (+  1  n)))) 

Figure  8-1.  Sample  Concurrent  Smalltalk  Method. 

The  method  returns  n  plus  the  length  of  a  Lisp-like  list  defined  by  objects  called  pairs  that  have  two 
fields:  car,  the  datum  field;  and  odr,  a  pointer  to  the  next  object  in  the  list. 


The  Front  End  converts  the  source  Concurrent  Smalltalk  method  into  I-Code  shown  in  Figure 
8-2.  The  I-Code  Preprocessor  then  processes  the  I-Code  to  add  enter  and  exit  statements 
and  merge  all  return  statements  into  one  reply  at  the  end  (Figure  8-3).  ^ 

(CSEND  (TEMP  0)  (METHOD  EQ)  (IVAR  1)  (CONST  NIL)) 

(FALSEJUMP  (TEMP  0)  0) 

(CSEND  (TEMP  1)  (METHOD  +)  (CONST  1)  (ARG  0)) 

(JUMP  1 ) 

(LABEL  0) 

(CSEND  (TEMP  2)  (METHOD  +)  (CONST  1 )  (ARG  0)) 

(CSEND  (TEMP  1 )  (METHOD  LENGTH  1 )  (IVAR  1 )  (TEMP  2))  I 

(LABEL  1) 

(RETURN-X  (TEMP  1)) 

Figure  8-2.  I-Code  for  the  Sample  Method. 

The  I-Code  output  by  the  Front  End  is  a  literal  translation  of  the  source  code  with  few  optimizations. 

At  this  point  all  method  calls,  including  primitives,  are  compiled  as  csends.  The  return-x  state¬ 
ment  at  the  end  performs  the  same  role  as  a  return  statement — it  returns  the  value  of  the  method  $ 

to  the  caller. 


j 


39 


A  Concurrent  Smalltalk  Compiler  for  the  Message-Driven  Processor 


(ENTER) 

(CSEND  (TEMP  0)  (METHOD  EQ)  (IVAR 1)  (CONST  NIL)) 

(FALSEJUMP  (TEMP  0)  0) 

(CSEND  (TEMP  1)  (METHOD  +)  (CONST  1)  (ARG  0)) 

(JUMP  1) 

(LABEL  0) 

(CSEND  (TEMP  2)  (METHOD  +)  (CONST  1)  (ARG  0)) 

(CSEND  (TEMP  1)  (METHOD  LENGTH  1)  (IVAR  1)  (TEMP  2)) 

(LABEL  1) 

(MOVE  (TEMP  RETURN- VALUE)  (TEMP  1)) 

(JUMP  RETURN) 

(JUMP  EXIT) 

(LABEL  RETURN) 

(REPLY  (TEMP  RETURN-VALUE)) 

(LABEL  EXIT) 

(EXIT) 

Figure  8-3.  Processed  I-Code  for  the  Sample  Method. 

The  preprocessor  added  some  dead  code  and  extra  branches  in  its  efforts  to  merge  return  and 
exit  statements.  That  dead  code  will  be  removed  when  the  (  Code  is  diagraphized. 


At  this  point  the  Diagraphizer  and  Canonarizer  are  invoked  to  produce  a  stmtgraph  of  the  I- 
Code.  The  printout  of  an  entire  stmtgraph  is  too  long  and  complicated;  instead,  the  result  of 
output-stmtgraph  run  on  the  stmtgraph  is  shown  in  Figure  8-4.  It  should  be  kept  in  mind  that 
output-stmtgraph  inserts  labels  and  unconditional  branches  in  its  output  that  are  not  present 
in  the  stmtgraph. 

(ENTER) 

(PRIMITIVE  (VAR  .  0)  EQ  (IVAR  .  1)  (CONST  0 . 0)) 

(CONDITION  BF  (VAR .  0)  193) 

(PRIMITIVE  (VAR  .  1)  +  (CONST  1.1)  (ARG .  0)) 

(LABEL  195) 

(MOVE  (VAR  .  2)  (VAR  .  1)) 

(REPLY (VAR.  2)) 

(EXIT) 

(LABEL  193) 

(PRIMITIVE  (VAR  .  3)  +  (CONST  1.1)  (ARG  .  0)) 

(CSEND  (VAR  .  1)  (CONST  METHOD  .  LENGTH  1)  (IVAR  .  1)  (VAR .  3)) 

(JUMP  195) 


Figure  8-4.  Initial  Stmtgraph  of  the  Sample  Method. 

The  primitives  have  been  recognized,  constants  reformatted  ( (const  a  .  b)  indicates  a  MDP 
word  with  tag  a  and  data  b),  and  local  variables  renumbered  to  start  at  0. 

Next  the  Dead  Definition  Eliminator  is  invoked  without  any  effects.  It  is  followed  by  the 
Move  Eliminator,  which  does  successfully  remove  the  unnecessary  move  statement. 


■ 


(ENTER) 

(PRIMITIVE  (VAR  .  0)  EQ  (IVAR  .  1)  (CONST  0 . 0)) 

(CONDITION  BF  (VAR .  0)  193) 

(PRIMITIVE  (VAR  .  1)  +  (CONST  1  . 1)  (ARG  .  0)) 

(LABEL  198) 

(REPLY  (VAR .  1)) 

(EXIT) 

(LABEL  193) 

(PRIMITIVE  (VAR  .  3)  +  (CONST  1  . 1)  (ARG  .  0)) 

(CSEND  (VAR  .  1)  (CONST  METHOD  .  LENGTH  1)  (IVAR  .  1)  (VAR  .  3)) 

(JUMP  198) 

Figure  8-5.  Stmtgraph  with  Move  Statement  Removed. 

The  Move  Eliminator  discovered  and  removed  the  unnecessary  move  stdtdflldnt. 
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There  are  no  touch  statements,  so  the  Touch  Eliminator  does  nothing.  However,  the 
Dataflow  Optimizer  spots  that  variable  0  is  the  result  of  testing  ivarl  against  nil,  and  it 
converts  the  branch-if-false  into  a  branch-if-not-nil  that  tests  ivarl  directly. 

(ENTER) 

(PRIMITIVE  (VAR .  0)  EQ  (IVAR  .  1 )  (CONST  0 . 0)) 

(CONDITION  BNNIL  (IVAR .  1)  193) 

(PRIMITIVE  (VAR  .  1)  +  (CONST  1.1)  (ARG  .  0)) 

(LABEL  198) 

(REPLY  (VAR.  1)) 

(EXIT) 

(LABEL  193) 

(PRIMITIVE  (VAR  .  3)  +  (CONST  1.1)  (ARG  .  0)) 

(CSEND  (VAR  .  1)  (CONST  METHOD  .  LENGTH  1)  (IVAR  .  1)  (VAR  .  3)) 

(JUMP  198) 

Figure  8-6.  Stmtgraph  Processed  by  Dataflow  Optimizer. 

The  Dataflow  Optimizer  optimized  the  conditional  branch  bf  to  a  bnnil,  but  it  did  not  remove  the 
now-redundant  original  test  of  ivarl  against  nil. 


The  Constant  Polder  does  not  find  any  constant  expressions  it  can  remove.  The  Tail 
Forwarder  does  spot,  however,  that  the  csend  is  followed  by  the  reply  statement. 

(ENTER) 

(PRIMITIVE  (VAR  .  0)  EQ  (IVAR  .  1)  (CONST  0 . 0)) 

(CONDITION  BNNIL  (IVAR  .  1)  193) 

(PRIMITIVE  (VAR  .  1 )  +  (CONST  1.1)  (ARG  .  0)) 

(REPLY  (VAR .  1)) 

(LABEL  199) 

(EXIT) 

(LABEL  193) 

(PRIMfTIVE  (VAR .  3)  +  (CONST  1.1)  (ARG .  0)) 

(RSEND  (CONST  METHOD  .  LENGTH  1)  (IVAR .  1)  (VAR  .  3)) 

(JUMP  199) 

Figure  8-7.  Stmtgraph  after  Tail  Forwarding. 

The  csend  has  been  converted  to  an  rsend  followed  by  a  branch  around  the  reply.  This 
optimization  not  only  decreases  the  code  size,  but  it  will  also  eliminate  the  need  to  allocate  a  con¬ 
text  in  Figure  8-13. 


The  Conditional  Folder  does  not  find  any  condition  both  of  whose  branches  point  to  the 
same  place,  and  the  Join  Merger  is  unsuccessful.  Nevertheless,  the  Fork  Merger  does  find 
the  +  primitive  on  both  sides  of  the  conditional,  and  it  moves  it  before  the  conditional. 

(ENTER) 

(PRIMITIVE  (VAR  .  0)  EQ  (IVAR  .  1 )  (CONST  0 . 0)) 

(MOVE  (VAR  .  5)  (IVAR  .  1)) 

(PRIMITIVE  (VAR  .  4)  +  (CONST  1.1)  (ARG  .  0)) 

(CONDITION  BNNIL  (VAR  .  5)  201 ) 

(MOVE  (VAR  .  1)  (VAR  .  4)) 

(REPLY  (VAR.  1)) 

(LABEL  199) 

(EXIT) 

(LABEL  201) 

(MOVE  (VAR  .  3)  (VAR .  4)) 

(RSEND  (CONST  METHOD  .  LENGTH1)  (IVAR  .  1)  (VAR  .  3)) 

(JUMP  199) 


-M 


Figure  8-8.  Stmtgraph  after  First  Optimization  Pass. 

The  Fork  Merger  successfully  moved  the  +  primitive  before  the  bnnil,  eliminating  one  +  but  also 
adding  three  move  statements. 
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Since  the  above  optimizations  did  change  the  stmtgraph,  the  Statement  Optimizer  makes 
another  pass  through  the  optimizations.  The  Dead  Definition  Eliminator  is  called  again,  and 
this  time  it  removes  the  redundant  eq  left  over  by  the  Dataflow  Optimizer  from  the  last  pass. 

(ENTER) 

(MOVE  (VAR.  5)  (IVAR.1)) 

(PRIMITIVE  (VAR .  4)  +  (CONST  1.1)  (ARG .  0)) 

(CONDITION  BNNIL  (VAR  .  5)  201 ) 

(MOVE  (VAR .  1)  (VAR .  4)) 

(REPLY  (VAR .  1)) 

(LABEL  199) 

(EXIT) 

(LABEL  201) 

(MOVE  (VAR .  3)  (VAR .  4)) 

(RSEND  (CONST  METHOD  .  LENGTH1)  (IVAR  .  1)  (VAR  .  3)) 

(JUMP  199) 

Figure  8-9.  Stmtgraph  with  Dead  Definitions  Removed. 

The  dead  eq  statement  was  finally  removed. 


The  Move  Eliminator  again  finds  moves  it  can  remove;  it  removes  two  move  statements  from 
the  stmtgraph.  The  move  from  ivarl  to  varS  is  not  removed  because  the  Move  Eliminator  only 
considers  moves  between  local  variables. 


(ENTER) 

(MOVE  (VAR  .  5)  (IVAR  .  1)) 

(PRIMITIVE  (VAR .  4)  +  (CONST  1.1)  (ARG  .  0)) 

(CONDITION  BNNIL  (VAR  .  5)  194) 

(REPLY (VAR.  4)) 

(LABEL  199) 

(EXIT) 

(LABEL  194) 

(RSEND  (CONST  METHOD  .  LENGTH1)  (IVAR .  1)  (VAR  .  4)) 

(JUMP  199) 

Figure  8-10.  Stmtgraph  with  Moves  Removed  (Again). 

Two  of  the  move  statements  introduced  by  the  Fork  Merger  are  now  gone. 


The  Touch  Eliminator  again  does  nothing,  while  the  Dataflow  Optimizer  changes  the  bnnil 
to  use  ivarl  directly  instead  of  varS,  thus  making  the  move  statement  dead. 

(ENTER) 

(MOVE  (VAR.  5)  (IVAR.1)) 

(PRIMITIVE  (VAR  .  4)  +  (CONST  1.1)  (ARG  .  0)) 

(CONDITION  BNNIL  (IVAR  .  1)  194) 

(REPLY  (VAR .  4)) 

(LABEL  199) 

(EXIT) 

(LABEL  194) 

(RSEND  (CONST  METHOD  .  LENGTH1)  (IVAR  .  1)  (VAR  .  4)) 

(JUMP  199) 

Figure  8-11.  Stmtgraph  after  Second  Dataflow  Optimization. 

Since  the  +  primitive  is  known  not  to  change  values  of  instance  variables,  the  Dataflow  Optimizer 
can  safely  change  bnnil's  variable  to  ivarl ,  thus  making  var5  dead. 


The  optimizations  remaining  in  the  second  pass  are  unable  to  make  any  improvements. 
Nevertheless,  since  the  second  pass  did  yield  changes,  a  third  pass  through  the  optimizations 
is  made.  This  time  the  Dead  Definition  Eliminator  spots  the  dead  move  and  eliminates  it. 


42 


Chapter  8 


Examples 


(ENTER) 

(PRIMITIVE  (VAR  .  4)  +  (CONST  1.1)  (ARG .  0)) 

(CONDITION  BNNIL  (IVAR .  1 )  1 94) 

(REPLY (VAR.  4)) 

(LABEL  199) 

(EXIT) 

(LABEL  194) 

(RSEND  (CONST  METHOD  .  LENGTH1)  (IVAR  .  1)  (VAR  .  4)) 

(JUMP  199) 

Figure  8-12.  Optimized  Stmtgraph. 

The  move  of  varS  is  now  gone,  and  no  more  optimizations  can  be  made. 


The  Statement  Optimizer  makes  one  more  pass  through  the  optimizations  without  finding 
any  changes,  so  it  returns  the  stmtgraph  shown  in  Figure  8-12.  The  Statement  Postprocessor 
does  not  make  any  changes  to  the  Stmtgraph,  so  that  stmtgraph  is  passed  to  the  Instruction 
Generator. 


The  Instruction  Generator  calls  the  Variable  Allocator  to  allocate  local  variables  and  create 
the  varinfo  record.  Only  var4  is  referenced,  and  it  is  allocated  to  register  R2,  so  the  varinfo 
record  is  as  shown  in  Figure  8-13. 

(VARINFO 

(NVLOCS  NIL) 

(NARGS  1) 

(NIVARS  2) 

(IVARS-USED  T) 

(VARLOCS  (0)  (1 )  (2)  (3)  (4  REG  .  2)  (5))) 

Figure  8-13.  Varinfo  Record. 

The  only  local  variable  is  assigned  to  R2.  Instance  variables  are  used  (ivars-used  is  true),  but  a 
context  is  not  needed  (nvlocs  is  nil). 


Next  the  stmtgraph  is  linearized  and  compiled  into  instructions.  The  module  that  is  the 
output  of  the  Instruction  Generator  is  shown  in  Figure  8-14.  As  with  stmtgraph s,  the  module 
is  too  long  and  complicated  to  show  in  a  figure;  instead,  the  Instruction  Printer  was  run  on 
the  module  to  show  what  it  would  have  been  if  it  had  been  output  before  any  of  the  Assembly 
Code  Generator's  transformations  are  done. 
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MODULE  PAIR _ LENGTH! 

DC  MSG:LoadCode+20 

DC  {Class_PAIR), (Method_LENGTHl) 


INIT-VLOCS  ;  0 

MOVE  [ 2 ,  A3 ] , RO  ;  0.5 

XLATE  RO , A2 , XLATE_OBJ  ;  1 

MOVE  1,R3  ;  1.5 

ADD  R3,  ( 3,  A3]  ,  R2  ;  2 

MOVE  [3,A2],R1  ;  2.5 

BNNIL  Rl, AL001  ;  3 

MOVE  [4,A3],R1  ;  3.5 

BNIL  Rl , AL002  ;  4 

DC  MSG:ReplyConst+4  ;  5 

WTAG  Rl, 1,R3  ;  6 

LSH  R3, -16,R3  ;  6.5 

SEND2  R3,R0  ;  7 

SEND  Rl  ;  7.5 

SEND  [5, A3]  ;  8 

SENDE  R2  ;  8.5 

L001:  MOVE  £3,A2],R0  ;  9 

CALL  Send_Node_Nr  ;  9.5 

DC  MSG: SendConst+7  ;  10 

SEND2  Rl ,  RO  ;  11 

DC  {Method_LENGTHl }  ;  12 

SEND  RO  ;  13 

SEND  [3,A2]  ;  13.5 

SEND  R2  ;  14 

SEND  [4, A3]  ;  14.5 

SENDE  [5, A3]  ;  15 

L002:  SUSPEND  ;  16 

END 


Figure  8-14.  Initial  Module. 

This  module  lacks  any  unconditional  branches  (which  are  represented  by  edges  of  the  module's  di¬ 
graph  not  shown  in  this  Figure). 

The  Branch  Inserter  runs  next  and  introduces  an  unconditional  branch.  Afterwards,  the 
Variable  Initializer  runs  and  converts  the  init-vlocs  pseudo-instruction  into  code  to 
initialize  context  variables;  there  are  none,  so  the  init-vlocs  pseudo-instruction  is  simply 
removed,  resulting  in  the  module  shown  in  Figure  8-15. 


44 


Chapter  8 


Examples 


MODULE  PAIR _ LENGTH 1 

DC  MSG : LoadCode+20 

DC  { Claas_PAIR } , { Method_LENGTHl } 


MOVE  [2, A31.R0  ;  0 

XLATE  RO , A2 , XLATE_OB J  ;  0.5 

MOVE  1.R3  ;  1 

ADD  R3 , [3,  A3] ,R2  ;  1.5 

MOVE  [3.A2J.R1  ;  2 

BNNIL  Rl, AL001  ;  2.5 

MOVE  [4.A31.R1  ;  3 

BNIL  Rl , *L002  ;  3.5 

DC  MSG:ReplyConst+4  ;  4 

WTAG  R1.1.R3  ;  5 

LSH  R3.-I6.R3  ;  5.5 

SEND2  R3.R0  ;  6 

SEND  Rl  ;  6.5 

SEND  [5, A3]  ;  7 

SENDE  R2  ;  7 . 5 

BR  AL002  ;  8 

L001:  MOVE  [3,A2],R0  ;  9 

CALL  Send_Node_Nr  ;  9.5 

DC  MSG:SendConst+7  ;  10 

SEND 2  Rl , RO  ;  11 

DC  { Method_LENGTH 1 )  ;  12 

SEND  RO  ;  13 

SEND  [3.A2]  ;  13.5 

SEND  R2  ;  14 

SEND  [4, A3]  ;  14.5 

SENDE  [5, A3]  ;  15 

L002:  SUSPEND  ;  16 

END 


Figure  8-15.  Module  before  Instruction  Optimization. 

This  module  is  already  correct  (it  does  not  need  any  branches  to  be  extended),  but  it  can  still  be 
optimized. 


Next  the  Instruction  Optimizer  and  the  Long  Branch  Handler  are  run.  The  module  does  not 
have  any  out-of-range  short  branches,  so  the  Long  Branch  Handler  does  nothing.  On  the 
other  hand,  the  Instruction  Optimizer  does  merge  two  pairs  of  send  instructions  to  yield,  at 
last,  the  final  output  shown  in  Figure  8-16.  Figure  8-17  shows  what  would  have  been  output 
had  all  nonessential  optimizations  been  turned  off. 
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MODULE  PAIR _ LENGTH1 

DC  MSG: LoadCoda+18 

DC  (Class_PAIR] , { Method_LENGTHl } 


MOVE  [2, A3] , RO  ;  0 

XLATE  RO , A2 , XLATE_OB J  ;  0.5 

MOVE  1,  R3  ;  1 

ADD  R3,  [3,  A3]  ,R2  ;  1.5 

MOVE  [3,A2],R1  ;  2 

BNNIL  Rl, AL001  ;  2.5 

MOVE  [4,A3],R1  ;  3 

BNIL  Rl , AL002  ;  3.5 

DC  MSG:  RaplyConat-f  4  ;  4 

MTAG  Rl , 1 , R3  ;  5 

LSH  R3, -16, R3  ;  5.5 

SEND2  R3.R0  ;  6 

SEND  Rl  ;  6 . 5 

SEND2E  [5, A3] ,R2  ;  7 

BR  AL002  ;  7.5 

L001:  MOVE  [3, A2] , RO  ;  8 

CALL  S«nd_Node_Nr  ;  8.5 

DC  MSG:SendConst+7  ;  9 

SEND 2  R1,R0  ;  10 

DC  {Method_LENGTHl}  ;  11 

SEND  RO  ;  12 

SEND 2  [ 3 , A2 ] , R2  ;  12.5 

SEND  (4, A3]  ;  13 

SENDE  [5, A3]  ;  13.5 

L002 :  SUSPEND  ;  14 

END 


Figure  8-16.  Final  Output. 

This  is  the  MDP  assembly  code  into  which  the  Concurrent  Smalltalk  source  code  in  Figure  8-1 
compiles. 

MODULE  PAIR _ LENGTH1 

DC  MSG: LoadCode+35 

DC  {Class_PAIR) , { Method_LENGTHl } 


MOVE  4 ,  RO  ;  0 

CALL  New_Context  ;  0.5 

MOVE  NIL, RO  ;  1 

MOVE  RO, [5, A1 ]  ;  1.5 

MOVE  RO, [6,A1]  ;  2 

MOVE  RO, [7, A1 ]  ;  2.5 

MOVE  RO, [8,A1]  ;  3 

MOVE  [2, A3] ,R0  ;  3.5 

XLATE  RO , A2 , XLATE_OB J  ;  4 

MOVE  [5,A1] ,R3  ;  4.5 

MOVE  [3,A2],R2  ;  5 

EQ  R2, NIL, Rl  ;  5.5 

MOVE  Rl , [5, A1 ]  ;  6 

MOVE  [5,A1],R3  ;  6.5 

BF  R3,AL001  ;  7 

MOVE  [6,A1],R2  ;  7.5 

MOVE  1,  R3  ;  8 

ADD  R3 , [ 3 , A3 ] , R3  ;  8.5 

MOVE  R3,[6,A1]  ;  9 

BR  AL002  ;  9.5 

L001:  MOVE  [8,AI],R2  ;  10 

MOVE  1 ,  R3  ;  10.5 

ADD  R3,(3,A3],R3  ;  11 

MOVE  R3,[8,A1J  ;  11.5 

MOVE  [6,A1] ,R2  ;  12 

MOVE  [8,A1],R3  ;  12.5 

MOVE  [3 , A2] , RO  ;  13 
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MOVE  [3,A2],R1  ;  13.5 

CALL  Sand_Nod«_Nr  ;  14 

DC  MSG:SendConst+7  ;  15 

SEND2  R1,R0  ;  16 

DC  (Method_LENGTHl }  ;  17 

SEND  RO  ;  18 

SEND  [3, A2]  ;  18.5 

SEND  [8,A1]  ;  19 

SEND  [ 1 , Al ]  ;  19.5 

SENDE  6  ;  20 

WTAG  Rl, 6, R1  ;  20.5 

MOVE  Rl,  [6, Al]  ;  21 

L002 :  MOVE  [7,A1],R3  ;  22 

MOVE  [ 6 , Al ] , RO  ;  22.5 

MOVE  RO, [7,A1]  ;  23 

MOVE  [ 7 , Al ] , R2  ;  23.5 

MOVE  [4,A3],R3  ;  24 

BNIL  R3, AL003  ;  24.5 

DC  MSG:ReplyConst-f4  ;  25 

WTAG  R3, 1, Rl  ;  26 

LSH  Rl, -16,R1  ;  26.5 

SEND2  R1,R0  ;  27 

SEND  R3  ;  27.5 

SEND  [5, A3]  ;  28 

SENDE  [ 7 , Al ]  ;  28.5 

L003:  MOVE  [5,A1],R1  ;  29 

MOVE  [ 6 , Al ] , R3  ;  29.5 

MOVE  [7, Al ] , R3  ;  30 

MOVE  [8, Al ] , R3  ;  30.5 

CALL  Free_Context  ;  31 

SUSPEND  ;  31.5 

END 


Figure  8-17.  Unoptimized  Output. 

This  is  the  output  of  the  compiler  from  the  source  code  in  Figure  8-1  when  all  nonessential 
optimizations  are  turned  off. 


Other  Examples 

Figure  8-18  is  an  example  of  an  accessor  method  that  is  automatically  defined  when  a  class 
(in  this  instance  the  class  pair  from  Figure  8-1)  is  defined. 

Figure  8-19  contains  a  listing  of  a  larger  Concurrent  Smalltalk  method  together  with  some 
supporting  methods.  InsertKey  compiles  into  142  words  and  uses  3  context  variables  when 
optimization  is  turned  on.  When  optimization  is  off,  it  cannot  be  compiled  at  all  because  it 
uses  too  many  context  variables;  but  if  it  could  be  compiled,  it  would  require  193  words  and 
18  context  variables. 
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MODULE  PAIR  CAR 

DC  MSG:LoadCode+10 

DC  (Class_PAIR) , {Method_CAR} 


MOVE  [2,A3],R0  ;  0 

XLATE  RO , A2 , XLATE_OB J  ;  0.5 

MOVE  (3, A3) ,R3  ;  1 

BNIL  R3,AL001  ;  1.5 

DC  MSG:ReplyConst+4  ;  2 

WTAG  R3 , 1 , R2  ;  3 

LSH  R2,-16,R2  ;  3.5 

SEND2  R2,R0  ;  4 

SEND  R3  ;  4.5 

SEND  [4,  A3)  ;  5 

SENDE  (2, A2]  ;  5.5 

L001:  SUSPEND  ;  6 

END 


Figure  8-18.  An  Accessor  Method, 

This  method  returns  the  value  of  one  of  the  instance  variables  of  its  instance  object. 

(method  bnode  p.i.e.  (p  i  e)  () 

(set  parent  p) 

(set  indices  i) 

(set  entries  e) 

(return  self)) 

(method  bnode  p.  (p)  () 

(set  parent  p)) 

(Method  Bnode  insertKey  (nkey)  (node-and-key  new-root) 

(if  (leaf?  self) 

(begin  (set  indices  (insert  indices  (find-place  indices  nkey  0) 
nkey)) 

(if  (>-  (length  indices)  10) 

(begin  (set  node-and-key  (split-node  self)) 

(if  (eq  parent  ‘0) 

(begin  (set  new-root  (new  bnode)) 

(p.i.e.  new-root '() 

(cons  (rest  node-and-key) '()) 

(cons  self  (cons  (first  node-and-key) '()))) 

(set  parent  new-root) 

(return  new-root)) 

(insertNode  parent  (first  node-and-key) 

(second  node-and-key)))) 

(return  indices))) 

(begin  (insertKey  (select-child  self  nkey)  nkey) 

(return  self)))) 

(method  bnode  leaf?  ()  () 

(eq  entries  *())) 

Figure  8-19.  A  Nontrivial  Concurrent  Smalltalk  Method. 

The  above  method,  courtesy  of  Andrew  Chien,  is  a  part  of  a  balanced  tree  handler. 
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Chapter  9.  Conclusion 

Results 

The  Optimist  compiler  does  work  as  expected  and  in  a  reasonable  amount  of  time.  The  code 
it  produces  is  compact,  and  there  are  no  obvious  simple  ways  of  significantly  improving  the 
code  density  or  speed  of  the  compiled  methods. 

I  did  successfully  load  the  compiled  methods  into  MDPSim,  the  MDP  simulator  [10],  but  I 
was  unable  to  run  them  because  the  operating  system  services  required  by  the  methods  were 
not  yet  ready.  I  will  try  to  run  the  compiled  methods  when  Brian  finishes  his  JOSS  operating 
system  [12]. 

Optimizations 

Although  many  of  the  optimizations  used  by  the  Optimist  compiler  are  generally  known,  they 
have  usually  been  applied  to  compilers  for  conventional  processors.  The  issues  involved  in 
compiling  for  the  MDP  are  quite  different  from  compiling  for  conventional  processors.  For 
instance,  keeping  the  code  size  small  and  dealing  with  unavailable  values  (futures)  are 
critical  issues  on  the  MDP,  while  they  are  either  not  particularly  important  or  not  relevant  on 
most  conventional  processors.  On  the  other  hand,  loops  and  pointers  are  important  areas 
(and  stumbling  blocks)  of  optimizations  for  conventional  processors,  while  they  are  not  a 
major  concern  on  the  MDP  (the  current  version  of  Concurrent  Smalltalk  does  not  even  have 
loops!). 

The  new  ideas  in  the  Optimist  compiler  include  juxtaposing  existing  optimizations  to  fit  the 
MDP.  Also,  I  did  include  optimizations  in  the  compiler  that  I  had  not  seen  before.  These 
include  the  Fork  and  Join  Mergers  which  can  make  unusual  improvements  to  the  generated 
code,  the  touch  optimizations,  the  Move  Eliminator  which  eliminates  move  statements  not 
caught  by  standard  copy  propagation  techniques  such  as  the  one  given  on  page  636  of  [2] 
(Figure  5-3),  the  Linearizer,  and  a  myriad  of  code  generator  optimizations,  many  of  them 
involving  MDP  idiosyncrasies  such  as  word-aligning  DCs,  avoiding  faults  during  message 
sends,  preventing  limbo  variables,  and  accomodating  long  branches  that  are  quite  annoying 
because  they  trash  an  important  register  when  used. 

Effects  of  Optimizations 

Having  the  various  optimizations  in  the  compiler  is  certainly  worthwhile.  After  examining 
the  compiler's  output  it  becomes  apparent  that  the  optimizations  are  more  than  a  luxury — 
they  are  essential  to  the  successful  use  of  Concurrent  Smalltalk  on  the  MDP.  The  compiler's 
optimizations  reduce  the  amount  of  code  output  by  anywhere  between  20%  and  60%  (or  even 
more  in  some  cases)  compared  to  the  Optimist  compiler's  output  with  all  nonessential 
optimizations  disabled.  The  larger  Concurrent  Smalltalk  methods  such  as  the  one  in  Figure 
8-19  cannot  be  compiled  at  all  without  the  optimizations  because  there  are  not  enough 
context  variables  on  the  MDP  available  for  use  as  the  method's  temporaries. 

All  of  the  compiler's  optimizations  are  important  to  some  extent,  and  there  is  a  symbiosis 
effect  among  the  various  optimizations;  for  example,  the  Move  Eliminator  and  the  Fork  and 
Join  Mergers  reinforce  each  other,  and  removing  one  would  drastically  reduce  the 
effectiveness  of  the  other.  However,  there  are  a  few  that  are  especially  useful: 
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Space  Optimizations 

•  The  preprocessor  and  the  Join  Merger  are  almost  always  successful  in  reducing  the 
number  of  reply  statements  in  the  compiled  code  to  either  zero  or  one.  Since  the  code  for  a 
reply  statement  does  require  a  significant  amount  of  space,  these  optimizations  are  very 
helpful. 

•  The  Register  Allocator  is  very  good  at  allocating  variables  to  registers,  often  being 
able  to  allocate  from  80%  to  100%  of  the  local  variables  to  registers.  Such  unusually  good 
performance  on  with  so  little  registers  is  due  to  the  Lisp-like  nature  of  Concurrent 
Smalltalk — almost  all  temporaries  are  live  for  only  one  statement.  Allocating  variables  in 
registers  results  in  significant  space  savings. 

•  The  Frame  Handler  produces  consistently  large  space  savings  in  the  generated  code. 
For  the  reasons  presented  in  its  description,  the  Stmt  Compiler  often  requests  a  guarantee 
that  certain  variables'  values  are  available;  if  it  is  unable  to  obtain  such  a  guarantee,  it 
touches  these  variables.  When  the  Frame  Handler  optimizations  are  turned  ofT,  a  significant 
amount  of  code  is  spent  touching  arguments  before  csends,  rsends,  replys,  and  even 
primitives. 

•  The  Move  Eliminator  complements  the  other  space  optimizations  by  removing  the 
extra  move  instructions  introduced  by  the  Front  End  and  various  other  optimizations. 

•  The  Fork  and  Join  Mergers,  when  they  are  successful,  are  capable  of  eliminating 
large  chunks  of  code.  The  programming  style  of  Concurrent  Smalltalk  encourages  writing 
expressions  that  can  be  merged  by  the  Fork  Merger,  such  as 

(if  test  (exprl  (calculate  a  b  c) ...) 

(expr2  (calculate  a  be) ...)) 

where  the  two  calls  to  calculate  on  both  sides  of  the  if  can  be  merged,  and  by  the  Join  Merger, 
such  as 

(if  test  (calculate  (expra  ...)  (exprb  ...)  (expre  ...)) 

(calculate  (exprd  ...)  (expre  ...)  (exprf  ...))) 

where  the  two  calls  to  calculate  on  both  sides  of  the  join  can  also  be  merged. 

Speed  and  Data  Space  Optimizations 

•  Tail  Forwarding  is  the  most  important  speed  and  data  space  optimization.  It  reduces 
the  data  space  required  by  many  tail-recursive  programs  from  linear  to  constant,  which  is 
extremely  important  in  the  limited  memory  environment  of  the  MDP.  Tail  Forwarding  also 
reduces  the  space  required  by  the  method  code  because  an  rsend  (a  tail  forwarded  method 
call)  takes  much  less  room  than  a  normal  csend  followed  by  a  reply  statement.  In  many 
small  methods  such  as  the  one  in  Figure  8-1  the  speed  savings  are  compounded  because  the 
conversion  of  a  csend  into  an  rsend  can  eliminate  the  need  to  allocate  a  context  object  for 
the  method,  saving  a  lot  of  time  on  entry  to  the  method. 

•  Another  very  important  speed  optimization  is  the  elimination  of  the  calls  to  allocate 
and  deallocate  a  context  object  if  the  method  does  not  have  any  context  variables,  which 
happens  when  all  local  variables  can  fit  in  registers  and  there  are  no  csends  with  local 
variables  as  targets  in  the  optimized  stmtgraph.  This  condition  holds  for  all  of  the  accessor 
methods  for  a  class  as  well  as  many  other  simple  methods  (see  Chapter  8).  The  speed  gains 
can  be  considerable  because  allocating  and  deallocating  a  context  takes  a  few  dozen 
instruction  cycles  in  the  operating  system,  which  for  small  methods  is  significantly  more  than 
the  time  spent  executing  the  actual  method  code. 
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*  Register  allocation  and  compaction  of  context  variables  by  the  Variable  Allocator  is  an 
important  data  space  saving  optimization.  It  is  usually  quite  successful — for  the  method  in 
Figure  8-19,  the  number  of  variables  in  the  context  was  reduced  from  18  (which  was  more 
than  the  MDP  can  address)  to  just  3. 

Programmer  Convenience  Optimizations 

•  The  Dataflow  Optimizer  and  Constant  Folder  are  very  good  at  eliminating  dead  code 
and  folding  various  constant  expressions.  These  optimizations  are  important  when  symbolic 
constant  expressions  or  debugging  code  controlled  by  a  constant  flag  is  included  in  the  source 
code.  A  Concurrent  Smalltalk  programmer  can  rest  easier  and  write  cleaner  programs  when 
he  knows  that  introducing  debugging  statements  controlled  by  a  constant  will  not  affect  the 
performance  of  his  code  when  debugging  is  turned  off. 

Impact  on  MDP  Project 

The  Optimist  compiler  fills  one  of  the  few  remaining  missing  links  in  the  abstraction  layers  of 
the  MDP  project.  The  layers  above  the  compiler  include  research  on  programing  in 
Concurrent  Smalltalk,  while  the  layers  below  the  compiler  are  the  JOSS  operating  system; 
the  MDP  Architecture;  MDPSim,  the  instruction  simulator;  and  various  lower-level  hardware 
simulators. 

As  expected,  implementing  the  compiler  made  apparent  minor  deficiencies  in  the  layers 
around  the  compiler.  Most  of  these  deficiencies  have  been  corrected  by  the  time  of  this 
writing,  and  this  thesis  lists  only  the  new  information.  On  the  higher  level,  the  syntax  of 
Concurrent  Smalltalk  was  changed  to  include  the  reply  and  return  statements,  implicit 
tail  forwarding  (instead  of  the  original  explicit  forward  requester  construct  which  led  to 
numerous  programmer  errors),  and  a  more  orthogonal  syntax  for  invoking  variable  methods 
and  passing  them  as  parameters  to  other  methods  (the  new  syntax  is  based  on  the  syntax  of 
the  Scheme  language  [1],  which  treats  functions  as  first-class  data  objects). 

Memory  Space 

The  deficiencies  on  the  lower  level,  the  MDP  Architecture  and  hardware,  were  more  serious. 

Implementing  the  compiler  required  the  addition  of  the  CFUT  data  type  to  be  able  to  mark 
variables  as  unavailable  (the  implementation  of  cfutb  in  the  MDP  still  isn't  done  quite  right, 
as  a  few  holes  remain  in  the  current  type-checking  system).  However,  the  most  serious 
problem  raised  by  the  compiler  is  the  lack  of  memory  space  on  the  MDP.  The  MDP  only  con¬ 
tains  4096  words  of  RAM,  and  much  of  that  space  is  taken  by  the  operating  system. 

Seemingly  small  methods  such  as  the  one  listed  in  Figure  8-19  can  easily  compile  into  a 
significant  fraction  of  the  MDP’s  memory  space.  Furthermore,  the  MDP’s  queues  are 
currently  set  to  accept  messages  up  to  128  words  in  length;  under  the  current  operating 
system,  the  method  in  Figure  8-19  could  not  even  be  sent  to  a  MDP! 

A  solution  to  the  memory  space  is  needed  before  the  MDP  project  can  continue.  Two 

alternatives  appear  to  be  reasonable  solutions.  One  is  to  increase  the  MDP's  memory  to  a  I 

reasonable  amount  such  as  16384  words.  That  amount  might  be  sufficient  to  fit  useful 

programs;  to  confirm  or  deny  this  claim  an  actual  useful  program  written  in  Concurrent 

Smalltalk  is  needed.  The  second  alternative  is  to  use  slow  off-chip  memory  to  supplement  the 

MDP's  on-chip  memory.  This  alternative  would  suffer  from  the  problem  of  deciding  what 

data  should  be  placed  on-chip  and  what  off-chip,  so  if  an  external  memory  interface  is  added 

to  the  MDP,  it  might  actually  be  better  to  convert  all  of  the  MDP's  on-chip  memory  into  one  j 

large  cache  for  the  off-chip  memory.  If  this  route  is  chosen,  the  MDP's  memory  space  would 
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be  limited  only  by  its  1-megaword  addressing  range,  but  the  MDP  would  lose  some  per¬ 
formance. 

Grain  Size 

The  initial  goal  for  the  MDP  project  was  to  have  the  MDP  execute  finely  grained  parallel 
programs  containing  about  twenty  instructions  per  method.  When  only  the  output  of  the 
compiler  is  examined,  this  goal  appears  to  have  been  met  (see  Figure  8-16).  Unfortunately,  it 
turns  out  that  for  various  reasons  the  system  calls  New_Context,  Free_Context,  and  especially 
the  method  dispatcher  (the  routine  that  runs  whenever  a  MDP  receives  a  SEND  method-call 
message)  and  the  fault  handling  routines  are  quite  long,  taking  dozens  of  instruction  times  to 
execute.  Thus,  if  the  time  spent  executing  operating  system  code  is  taken  into  account,  the 
grain  size  is  approximately  50  to  100  instructions  (50  instructions  >  5  |is  at  10? 
in structiona/sec),  which  is  still  very  good  compared  with  other  parallel  computer  efforts. 

Future  Improvements 

The  compiler  is  an  evolving  project,  and  I  plan  on  improving  it  over  time  to  fit  the  needs  of 
the  MDP  project.  The  obvious  additions  to  the  compiler  include  support  of  global  variables 
and  lexically  scoped  blocks.  These  features  were  not  included  in  this  revision  of  the  compiler 
because  it  is  not  clear  how  the  operating  system  would  support  them. 

Additional  work  can  be  done  on  the  compiler's  optimizations.  One  type  of  optimization  that 
needs  to  be  added  is  global  optimizations  such  as  inlining  small  methods  when  appropriate. 
It  is  good  programming  style  to  write  little  abstraction  methods  like  leaf?  in  Figure  8-19  that 
perform  a  very  simple  task  and  return.  Unfortunately,  all  such  methods  are  currently 
compiled  as  method  calls  because  the  compiler  only  has  access  to  one  method  at  a  time  while 
compiling.  Compiling  these  methods  as  calls  often  leads  to  a  large  waste  of  time  as  well  as 
code  space;  for  example,  in  the  method  insertKey,  the  call  to  leaf?  could  be  replaced  by  an 
inline  check  of  the  entries  variable,  saving  both  space  and  time. 

Another  possible  improvement  is  fine-tuning  the  register  assignment  process.  Currently  the 
register  assigner  works  with  conservative  estimates  of  the  maximum  number  of  temporary 
registers  required  by  a  statement.  These  estimates  could  be  improved  by  considering  more 
data. 

Finally,  in  some  cases  it  might  be  desirable  to  keep  a  variable  in  memory  for  a  part  of  its 
lifetime  and  in  a  register  for  another  part.  One  simple  approach  to  achieve  this  goal  in  many 
cases  is  to  split  a  variable  into  two  or  more  variables  as  in  the  example  below: 

(cset  a  (expression  1  ...)) 

(expression  a ...) 

(cset  a  (expression  ...)) 

(expression  a ...) 

can  be  changed  to 

(cset  b  (expression  1  ...)) 

(expression  b ...) 

(cset  c  (expressions  ...)) 

(expression  c ...) 

Now  b  and  c  are  live  in  disjoint  intervals,  so  in  the  worst  case  they  will  be  placed  in  the  same 
context  variable  or  the  same  register.  It  is  possible,  though,  that  one  of  *hem  will  be  placed  in 
memory  and  the  other  in  a  register,  whereas  in  the  original  code  a  would  then  be  placed  in 
memory. 
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Conclusion 


Summary 

The  Optimist  compiler  compiles  Concurrent  Smalltalk  to  the  MDP  assembly  language. 
Although  the  compiler  includes  various  optimizations  such  as  dead  code  elimination,  dataflow 
analysis,  constant  folding,  move  elimination,  duplicate  code  merging,  tail  forwarding,  use  of 
register  variables,  and  not  allocating  a  context  unless  necessary,  the  size  of  the  compiled  code 
appears  to  be  larger  than  was  anticipated,  and  it  is  unlikely  that  application  programs  will  fit 
(together  with  their  data  and  the  RAM-based  portion  of  the  operating  system!)  in  the  4096 
words  available  on  the  MDP  prototype.  Once  the  memory  size  problem  is  resolved,  however, 
the  future  of  the  MDP  project  looks  very  bright,  as  it  appears  that  the  methods  compiled  by 
this  compiler  will  have  a  reasonably  small  (20  to  100  instructions)  grain  size. 
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Appendix  A.  MDP  Architecture  Summary 

This  Appendix  is  a  summary  of  the  version  10  MDP  Architecture  document  [9].  Many  details 
have  been  simplified  in  order  to  keep  this  Appendix  to  a  reasonable  length. 

Introduction 

The  Message-Driven  Processor  is  a  processing  node  for  the  J-Machine,  a  message-passing 
concurrent  computer.  The  MDP  is  designed  to  provide  support  for  fine-grained  concurrent 
computation.  Towards  this  goal  the  processor  includes  hardware  for  message  queueing,  low- 
latent^  message  dispatching,  and  message  sending.  The  same  chip  also  contains  a  network 
interface  and  a  router  to  allow  the  routing  of  messages  throughout  the  network  without  any 
processor  intervention. 

The  size  of  the  MDFs  register  set  is  limited  to  minimize  context-switching  time.  The  memory 
is  on  the  chip  to  improve  performance  and  reduce  the  chip's  pin  count  and  the  chip  count  for 
the  concurrent  computer.  Having  memory  on  chip  allows  more  flexibility  in  the  use  of 
memory  than  in  designs  with  off-chip  memory.  For  example,  a  portion  of  memory  may  be 
designated  as  a  two-way  set-associative  cache  to  be  used  by  the  xlate  instruction. 

The  MDP  is  also  designed  to  efficiently  support  object-oriented  programming.  Every  MDP 
word  consists  of  32  bits  and  a  4  bit  tag  that  classifies  the  word  as  an  integer,  boolean, 
address,  instruction,  pointer,  or  other  data.  The  MDP's  four  address  registers  include  both 
base  addresses  and  lengths,  so  all  memory  accesses  are  bounds  checked.  Normally  the 
address  registers  point  to  objects,  so,  since  absolute  memory  addressing  is  not  allowed  except 
by  the  operating  system,  memory  references  can  only  be  made  to  objects  relative  to  their  be¬ 
ginnings.  Having  tags  and  no  absolute  references  permits  the  use  of  garbage  collection  and 
transparent  migration  of  objects  to  other  MDP  nodes  on  the  network. 

The  MDP  is  almost  completely  message-driven.  It  is  controlled  by  the  messages  arriving 
from  the  network  that  are  automatically  queued  and  processed.  There  are  two  priority  levels 
to  allow  urgent  messages  to  interrupt  normal  processing.  There  is  also  limited  support  for  a 
background  mode  of  execution  when  no  messages  are  waiting  in  the  queues. 


Processor  State 


The  processor  state  of  the  MDP  is  kept  in  a  set  of  registers  shown  in  Figure  A-l.  There  are 
two  independent  copies  of  most  registers  registers  for  each  of  the  two  priorities  of  the  MDP, 
allowing  easy  priority  switches  while  keeping  the  integrity  of  the  registers.  The  registers  are 
symbolically  represented  as  follows: 


•  R0-R3 

•  AO -A3 

•  ID0-ID3 

•  SR 

•  IP 

•  TRP 

•  SP 

•  QBM 

•  QHL 

•  TBM 

•  NNR 


general-purpose  data  registers 
address  registers 
ID  registers 
status  register 
instruction  pointer  register 
trapped  instruction  register 
stack  pointer  register 
queue  base/limit  register 
queue  head/tail  register 
translation  base/mask  register 
node  number  register 
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MDP  Architecture  Summary 
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Figure  A-l.  The  MDP  Register  Set. 

Data  Types 

The  following  data  types  that  may  be  used  in  a  word  are  shown  in  Figure  A-2.  All  data  types 
except  possibly  FUT  and  CFUT  may  be  moved,  compared  with  eq  and  NEQ,  XLATEd  and 
ENTERed,  RTAGged,  WTAGged,  CHECKed,  and  executed.  Executing  a  non-iNST  word  causes  it 
to  be  loaded  into  R0.  Some  data  types  allow  additional  operations,  which  are  listed  in  detail 
in  the  description  of  the  instruction  set. 
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Figure  A-2.  The  MDP  Data  Types. 

•  sym  contains  an  atomic  symbol,  equal  and  nequal  are  allowed  on  SYMbols.  If  the  data 
portion  of  a  symbol  contains  all  zeroes,  the  word  takes  on  the  value  of  nil. 

•  int  contains  a  two's  complement  integer  between  -231  and  231-!,  inclusive.  All  arith¬ 
metic,  logical,  and  comparison  operations  are  allowed  on  ints. 

•  bool  contains  a  boolean  value,  which  is  either  true  (b=l )  or  false  (b=0).  max,  min  and  all 
logical,  and  comparison  operations  are  allowed  on  bools.  For  purposes  of  max,  min, 
and  the  comparisons,  false  is  considered  as  less  than  true. 

•  addr  contains  a  base/length  pair  that  may  be  loaded  into  either  one  of  the  address  regis¬ 
ters  or  qbm,  qhl,  or  tbm.  The  uses  of  bits  30  and  31  vary  among  these  registers. 

•  ip  contains  a  value  appropriate  for  loading  into  the  ip. 

•  msg  is  the  header  of  a  message.  It  is  similar  to  an  ip. 

•  cfut  contains  a  context  future.  Almost  all  operations  fault  on  context  futures.  They  are 
not  meant  to  be  MOVEable.  cfuts  are  used  as  placeholders  for  unavailable  values  to  be 
computed  in  parallel  by  other  processes;  an  attempt  to  read  a  cfut  before  its  value  is 
available  will  fault,  and  the  operating  system  will  suspend  the  current  process  until  the 
value  is  available. 

•  fut  is  a  standard  future,  futs  may  be  moved,  and  their  tags  may  be  read  and  written, 
but  they  may  not  participate  in  any  primitive  operations  such  as  addition  or  checking  for 
equality.  As  with  cfuts,  an  attempt  to  use  a  fut  in  a  primitive  operation  will  cause  a 
fault,  and  the  operating  system  will  have  to  provide  the  appropriate  value  for  the  fut. 

•  tag 8  through  tagb  are  tags  for  software-defined  words.  They  cause  faults  on  all  primi¬ 
tive  operations  except  eq,  neq,  bnil,  and  bnnil. 

•  insto  through  inst3  are  tags  for  instructions.  The  two  instructions  in  a  word  occupy  a 
total  of  34  bits,  so  two  tag  bits  are  also  used  to  encode  them. 
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MDP  Architecture  Summary 


Network  Interface 

Incoming  messages  are  queued  in  message  queues  before  being  dispatched  and  processed. 
There  are  two  message  queues,  one  for  each  priority  level.  When  a  message  arrives,  register 
A3  is  set  up  to  point  to  it  in  the  message  queue,  and  execution  begins  at  the  address  specified 
by  the  message  header.  A  message  may  be  processed  as  soon  as  its  first  word  arrives;  the 
processor  does  not  wait  until  the  entire  message  is  present  before  processing  it.  Memory 
accesses  to  the  message  are  checked  to  make  sure  that  the  processor  does  not  try  to  access  a 
word  in  the  message  before  it  arrives;  if  the  processor  tries  to  access  a  word  too  early,  it  waits 
until  the  word  has  arrived. 

The  SUSPEND  instruction  informs  the  hardware  that  the  processing  of  the  current  message  is 
done  and  that  it  should  fetch  the  next  message. 

Message  Transmission 

The  SEND,  send2,  SENDE,  and  SEND2E  instructions  are  used  to  send  messages.  The  first 
word  sent  specifies  the  node  number  of  the  destination  node  (i.e.  the  destination  node's  nnr 
value)  in  the  low  16  bits.  The  SEND  instruction  will  use  the  current  node's  NNR  and  the 
destination  node  number  to  find  the  relative  offsets  in  the  X  and  Y  dimensions  that  the 
network  controllers  will  use  in  routing  the  messages  through  the  network.  Bit  31  determines 
the  priority  at  which  the  message  will  be  sent  over  the  network:  0  means  priority  level  0  and 
1  means  level  1.  The  priority  of  the  message  is  independent  of  the  priority  of  the  process  that 
is  sending  it 

The  initial  routing  word  is  followed  by  a  number  of  words  which  the  network  delivers 
verbatim  to  the  destination  node.  The  network  does  not  examine  the  contents  of  these  words. 
The  message  is  terminated  by  a  SENDE  or  SEND2E  instruction,  which  send  the  last  one  or  two, 
respectively,  words  of  it  and  inform  the  network  to  actually  transmit  the  message.  The  first 
word  that  arrives  at  the  destination  node  (the  second  word  actually  sent  since  the  routing 
word  is  only  used  by  the  network  and  doesn't  arrive  at  the  destination  node)  must  be  tagged 
MSG.  It  contains  the  length  of  that  message  including  that  word  but  not  including  the  routing 
word  preceding  it.  It  also  contains  the  initial  value  of  the  IP  at  which  execution  is  supposed 
to  start  The  destination  node  will  fault  MSG  if  this  word  is  incorrect. 

The  total  time  between  the  first  SEND  and  the  SENDE  should  be  as  short  as  possible  to  avoid 
blocking  the  network.  For  the  same  reason,  faults  should  be  avoided  while  sending.  There  is 
a  small  (8  words  or  so)  send  buffer  present.  If  a  message  exceeds  the  size  of  the  send  buffer, 
interrupts  are  internally  disabled  until  the  next  SENDE. 

Fault  Processing 

When  a  fault  occurs,  the  current  ip  is  incremented  to  the  next  instruction  and  pushed  on  the 
current  priority's  stack.  The  instruction  that  caused  the  fault  is  saved  in  the  trp  register  and 
the  IP  is  then  fetched  from  the  memory  location  whose  address  is  equal  to  the  fault  number. 

Instruction  Encoding 

The  program  executed  by  the  MDP  consists  of  instructions  and  constants.  A  constant  is  any 
word  not  tagged  INSTO  through  INST3  that  is  encountered  in  the  instruction  stream.  When 
a  constant  word  is  encountered,  that  word  is  loaded  into  RO  and  execution  proceeds  with  the 
next  word  (the  assembler  syntax  for  including  a  word  in  the  code  stream  is  DC). 
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Every  instruction  is  17  bits  long.  Two  17-bit  instructions  are  packed  into  a  word.  Since  a 
word  has  only  32  data  bits,  two  tag  bits  are  also  used  to  specify  the  instructions.  The 
instruction  in  the  high  part  of  the  word  is  executed  first,  followed  by  the  instruction  in  the 
low  part  of  the  word.  As  a  matter  of  convention,  if  only  one  instruction  is  present  in  a  word,  it 
should  be  placed  in  the  high  part,  and  the  low  part  of  the  word  set  to  all  zeros. 

The  format  of  an  instruction  is  as  follows: 


16  11  10  9  8  7  6  0 
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The  opcode  field  specifies  one  of  64  possible  instructions.  The  other  fields  specify  three 
operands;  instructions  that  don't  require  three  operands  ignore  some  of  the  operand  fields. 
Operands  1  and  2  must  be  data  registers;  their  numbers  (0  through  3)  are  encoded  in  the  1st 
reg  #  and  2nd  reg  it  fields.  Operand  2,  if  used,  is  always  the  destination  of  an  operation  and 
operand  1,  if  used,  is  always  a  source. 
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Figure  A-3.  The  MDP  Normal  Addressing  Modes. 

The  immediate  constants  are  eight  immediate  values  outside  the  range  int:  -16..INT:  15.  They 
are  provided  for  convenience  and  code  density  improvement.  The  $FF  and  $FFFF  constants  are 
useful  for  masking  bytes  and  words,  while  the  $3FF  and  $FFFFF  constants  may  be  used  for  mask¬ 
ing  lengths  and  addresses. 


Operand  0  can  be  used  as  a  source  or  a  destination  in  an  instruction.  It  can  hold  two  possible 
encodings.  A  normal  instruction  has  opO  address  mode  encodings  as  shown  in  Figure  A-3. 
The  register-oriented  opO  mode  is  used  instead  b*  a  few  instructions  such  as  PUSH  and  POP; 
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the  MOVE  instructions  allow  both  address  mode  encodings.  If  an  instruction  uses  the  register- 
oriented  opO,  the  encodings  are  as  in  Figure  A-4. 
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Addressing  Mode 

Rn 

Rn' 

Data  register  Rn 

An 

An' 

Address  register  An 

IDn 

IDn' 

ID  register  IDn 

Unused  (ILGADRMD  fault) 

QBM 

QBM' 

Queue  Base/Mask  register 

QHL 

QHL' 

Queue  Head/Length  register 

IP 

IP' 

Instruction  Pointer  register 

SP 

SP' 

Stack  Pointer  register 

TRP 

TRP' 

Trapped  Instruction  register 

TBM 

Translation  Base/Mask  register 

NNR 

Node  Number  register 

Unused  (ILGADRMD  fault) 

P 

Priority  Level  flag 

B 

Background  Execution  flag 

I 

Interrupt  flag 

F 

F' 

Fault  flag 

U 

U' 

Unchecked  flag 

Q 

Q' 

A3  Queue  flag 

Unused  flag  (ILGADRMD  fault) 
Unused  flag  (ILGADRMD  fault) 
Unused  (ILGADRMD  fault) 
Unused  (ILGADRMD  fault) 
Unused  (ILGADRMD  fault) 
iOREGn  I/O  register  lOREGn 


Figure  A-4.  The  MDP  Register  Oriented  Addressing  Modes. 

P  represents  the  priority  of  the  register  being  accessed,  and  is  relative  to  the  current  priority.  0 
indicates  the  current  priority,  white  1  indicates  the  other  priority.  The  assembler  syntax  for  specify¬ 
ing  a  register  belonging  to  the  other  priority  is  the  register  name  followed  by  a  backquote  (').  The 
I/O  register  mode  is  reserved  to  provide  access  to  various  other  registers  that  will  be  needed  to  in¬ 
terface  the  MDP  to  I/O  devices. 
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Instruction  Set  Summary 

The  instructions  supported  by  the  MDP  are  summarized  in  Table  A-l.  The  Types  column 
specifies  the  types  on  which  the  instruction  operates;  if  the  arguments  have  different  types, 
the  instruction  faults.  Almost  all  instructions  with  the  notable  exception  of  move  to  memory 
fault  when  any  of  their  operands  are  tagged  cfut. 


Table  A-l.  MDP  Instructions 


Instruction 

Brief  Description 

Types 

General  Movement  and  Type  Instructions 

MOVE 

Src, Rd 

Rd«—  Src 

All 

MOVE 

Rs,Dst 

Dst «—  Rs 

AH 

RTAG 

Src, Rd 

Rd«-  INTlag(Src) 

All 

WTAG 

Rs, Src, Rd 

Rd*-  Src:Rs 

All 

PUSH 

Src 

Push  Src  on  the  stack 

All 

POP 

Dat 

Pop  the  stack  into  Dst 

All 

CHECK 

Rs , Src, Rd 

Rd«—  BOOL!tag(Rs)=Src 

All 

Arithmetic  and  Logical  Instructions 

NEG 

Src,Rd 

Rd* — Src 

INT 

ADD 

Rs, Src, Rd 

Rd<—  Rs+Src 

INT 

SUB 

Rs, Src, Rd 

Rd*—  Rs-Src 

INT 

CARRY 

Rs,  Src, Rd 

Rd  *-  Carry  from  the  addition  of  Rs  and  src 

INT 

MAX 

Rs, Src,Rd 

If  Rs^Src  then  Rd  «-  Rs  else  Rd «-  Src 

INT,  BOOL 

MIN 

Rs ,  S  rc , Rd 

If  Rs<s  rc  then  Rd <-  Rs  else  Rd  *-  s  r  c 

INT,  BOOL 

MUL 

Rs, Src, Rd 

Rd<—  Rs*Src 

INT 

MULH 

Rs, Src, Rd 

Rd  <-  High  32  bits  of  64-bit  unsigned  product  of  rs  and  Src 

INT 

ASH 

Rs,  Src, Rd 

Rd  *-  rs  shifted  left  arithmetically  by  s  r  c  bits 

INT 

LSH 

Rs,  Src, Rd 

Rd  <-  Rs  shifted  left  logically  by  Src  bits 

INT 

ROT 

Rs,  Src, Rd 

Rd  <-  Rs  rotated  left  by  Src  (mod  32)  bits 

INT 

NOT 

Src,  Rd 

Rd  <—  NOT  Src 

INT,  BOOL 

AND 

R3,  Src, Rd 

Rd<—  Rs  AND  Src 

INT,  BOOL 

OR 

Rs,  Src,Rd 

Rd  *-  Rs  OR  Src 

INT,  BOOL 

XOR 

Rs,  Src,Rd 

Rd*—  Rs  XOR  Src 

INT,  BOOL 

LT 

Rs,  Src, Rd 

Rd  <—  BOOL.’Rs<Src 

INT,  BOOL 

LE 

Rs,  Src, Rd 

Rd*—  BOOL!Rs<Src 

INT,  BOOL 

GT 

Rs,  Src, Rd 

Rd«-  BOOL:Rs>Src 

INT,  BOOL 

GE 

Rs,  Src, Rd 

Rd*-  BOOL:Rs£Src 

INT,  BOOL 

EQUAL 

Rs,  Src, Rd 

Rd  *-  BOOL:Rs=S  rc 

SYM,  INT,  BOOL 

NEQUAL 

Rs,  Src, Rd 

Rd  <—  BOOL:Rs*S  rc 

SYM,  INT,  BOOL 

EQ 

Rs,  Src,  Rd 

Rd  <-  BOOL:Rs=Src  (Pointer  comparison  only) 

All 

NEQ 

Rs,  Src, Rd 

Rd  *-  bool:rs^s  rc  (Pointer  comparison  only) 

All 

Network  Instructions 

SEND 

Src 

Send  s  rc  onto  the  network 

All 

SENDE 

Src 

Send  Src  onto  the  network  and  terminate  message 

All 

SEND2 

Rs, Src 

Send  rs  and  Src  onto  the  network 

All 

SEND2E 

Rs ,  S  rc 

Send  Rs  and  Src  onto  the  network  and  terminate  message 

All 
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Associative  Lookup  Table  Instructions 


XLATE 

RS/Dst/C 

Dst  <-  associative  lookup  in  the  associative  lookup  table  of  Rs 

All 

ENTER 

Src,Rs 

Enter  (Src,  Dst)  into  the  associative  lookup  table 

All 

PROBE 

Src, Rd 

Rd «-  BooL:src  is  in  the  associative  lookup  table 

All 

PURGE 

Rs 

Remove  rs  from  the  associative  lookup  table 

All 

Special  Instructions 

INVAL 

SUSPEND 

CALL  Src 

Invalidate  all  relocatable  address  registers 

Terminate  current  process  and  fetch  another  message 

Call  system  routine  numbered  Src 

RES 

Src 

IP  <-  Src 

IP 

Branches 

BR  Src 

Branch  forward  Src  words 

BNXL 

Rs, Src 

Branch  forward  s  r  c  words  if  rs  is  ni  l 

All 

BNNIL 

Rs, Src 

Branch  forward  s  r  c  words  if  Rs  is  not  ni  l 

All 

BF 

Rs, Src 

Branch  forward  s  r  c  words  if  Rs  is  false 

BOOL 

BT 

Rs, Src 

Branch  forward  src  words  if  rs  is  true 

BOOL 

BZ 

Rs, Src 

Branch  forward  Src  words  if  Rs  is  zero 

I  NT 

BNZ 

Rs, Src 

Branch  forward  src  words  if  Rs  is  non-zero 

I  NT 
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Registers 

Methods  generated  by  the  compiler  use  the  data,  address,  ID,  and  nnr  registers.  The 
registers  are  used  for  the  purposes  listed  in  Table  B-l. 


Table  B-l.  Compiler  Register  Usage 


Register 

R0.R1.R2.R3 
AO,  IDO 
Al,  IDI 
A2, ID2 
A3,  ID3 
NNR 


Use 

Temporaries  used  by  the  method  code. 

Pointer  to  method  that  is  executing.  Set  up  by  the  operating  system. 
Pointer  to  the  context  object  or  nil  if  there  is  none. 

Pointer  to  the  instance  object. 

Pointer  to  the  message  that  invoked  the  method. 

Node  number  of  this  node. 


When  the  incoming  message  arrives,  the  operating  system  should  set  A3,  ID3,  AO,  and  ido  to 
their  correct  values  and  IDI  to  NIL  before  calling  the  method.  NNR  should  always  be  the  node 
number  of  the  node. 


Faults 

The  operating  system  is  expected  to  handle  the  common  faults  that  arise  during  execution  of 
user  programs.  In  particular,  the  operating  system  should  handle  the  following  faults: 

•  type  and  related  faults:  These  faults  occur  if  a  primitive  selector  is  invoked  on  a 
non-primitive  receiver  (i.e.  +  is  attempted  on  a  matrix).  The  operating  system  should  send 
the  appropriate  message  to  the  receiver  object,  wait  for  the  reply,  and  store  the  result  in  the 
destination  register  of  the  instruction  that  caused  the  fault  or  emulate  the  behavior  of  the 
instruction  if  it  was  a  condition. 

•  overflow:  This  fault  occurs  when  an  integer  operation  overflows  the  signed  32-bit 
range.  In  this  case  the  operating  system  should  call  an  extended  precision  integer  package  to 
determine  the  result  and  store  the  result  in  the  destination  register  of  the  instruction  that 
caused  the  fault. 

•  CFUT:  This  is  probably  the  most  common  fault.  It  occurs  whenever  the  method 
attempts  to  use  the  result  of  a  SEND  for  which  a  REPLY  has  not  yet  been  received.  The 
operating  system  should  suspend  execution  of  the  method  until  the  reply  does  arrive  and  then 
restart  the  instruction  that  caused  the  fault. 

•  Any  system  faults  not  related  to  the  executing  method. 

For  all  of  the  faults  it  is  important  that  the  operating  system  preserve  all  data  and  ID 
registers. 

Data  Structures 

The  data  structures  referenced  by  the  compiler  include  the  incoming  message,  the  context, 
and  the  instance  object,  if  any,  of  the  method's  class.  The  format  of  the  incoming  message  is 
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shown  in  Figure  B-3.  Register  A3  always  points  to  the  message  that  invoked  the  method 
during  the  execution  of  the  method. 
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*|  Context  Class 

Object  Length 

1 

ID 

Context  Object  ID 

2 

Reserved  for  Operating  System 

3 

Reserved  for  Operating  System 

m 

4 

Reserved  for  Operating  System 

5 

Variable  0 

6 

Variable  1 

:’;<X 

■ 

4+n 

Variable  n-1 

| 

5+n 

Reserved  for  Operating  System 

!; 

Reserved  for  Operating  System 

::x: 

: 

Figure  B-l.  Context  Object  Format 

The  context  object  is  addressed  by  register  A1 .  It  contains  the  values  of  the  method's  local  vari¬ 
ables,  the  values  of  the  registers  when  the  method  is  suspended,  as  well  as  other  miscellaneous 
information  used  by  the  operating  system.  Context  Class  is  a  constant  that  identifies  this  object  as 
a  context.  *  represents  a  few  bits  reserved  for  the  operating  system. 
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Class 

Object  Length 
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ID 

Instance  Object  ID  | 

2 

Instance  Variable  0 

3 

Instance  Variable  1 

1+n 

Instance  Variable  n-1 

Figure  B-2.  Instance  Object  Format 

The  instance  object,  if  any,  is  addressed  by  register  A2.  It  contains  the  variables  of  the  instance 
object  on  which  the  method  is  operating.  Class  is  the  instance  object's  class.  *  represents  a  few 
bits  reserved  for  the  operating  system. 

The  context  object  has  the  format  shown  in  Figure  B-l.  The  only  fields  relevant  to  the 
compiler  are  the  ID  field  that  is  sent  in  the  reply  ID  field  of  all  outgoing  SEND  messages  that 
request  a  reply  and  the  local  variable  fields  that  are  used  for  local  variable  storage  as  well  as 
slots  into  which  values  returned  by  REPLY  messages  are  stored. 

Unless  the  class  is  atomic,  the  method  is  called  on  an  instance  object.  If  the  instance  object  is 
needed  for  execution  of  the  method,  the  instance  object  ID  is  taken  from  receiver  field  of  the 
caller's  message  and  XLATEd  into  register  A2.  Instance  variables  are  then  addressed  as 
offsets  from  register  A2.  The  compiler  permits  the  instance  object  to  migrate  away  during  the 
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execution  of  the  method,  in  which  case  the  next  access  of  an  instance  variable  will  fault,  and 
the  operating  system  will  have  to  bring  the  object  back. 

Message  Formats 


There  are  currently  three  kinds  of  messages  used  by  the  compiler  SEND  messages,  REPLY 
messages,  and  CODE  messages.  Their  formats  are  shown  in  Figure  B-3. 
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Figure  B-3.  SEND  Message  Formats 

The  format  of  a  SEND  message  that  expects  a  reply  is  shown  in  (a),  while  the  SEND  message  in 
(b)  does  not  expect  a  reply.  The  formats  in  (c)  and  (d)  are  the  same  except  that  an  additional  word 
is  sent  indicating  the  node  number  of  the  node  to  which  the  reply  should  be  sent.  Formats  (c)  and 
(d)  are  used  when  the  ‘reply-node*  flag  is  set. 

A  SEND  message  requests  the  execution  of  a  method  of  the  receiver  object.  The  selector 
specifying  the  method  is  the  second  word  of  the  message,  and  the  receiver  object  is  the  third, 
followed  by  additional  arguments,  if  any.  If  the  caller  expects  a  reply,  it  will  indicate  its  ID 
and  slot  after  the  arguments.  If  the  ‘reply-node*  compiler  flag  is  set,  the  caller  includes  an 
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additional  word  containing  the  caller's  node  number.  The  called  method  should  then  copy  the 
ID  and  slot  into  the  REPLY  message  along  with  the  reply  value.  If  no  reply  is  expected,  the 
last  two  (or  three  if ‘reply-node*  is  set)  words  of  the  message  are  set  to  nil. 


0 

MSG 

Reply  Const 

_ * _ 1 

1 

ID 

Context  ID  for  reply 

2 

INT 

Context  slot  for  reply 

3 

Reply  Value  j 

Figure  B-4.  REPLY  Message  Format 

The  REPLY  message  asks  the  operating  system  to  store  the  reply  value  h  the  given  slot  (offset 
from  the  beginning  of  the  context)  of  the  context  with  the  given  ID.  The  caller  should  have  reserved 
the  slot  for  the  reply  by  putting  a  CFUT  in  the  specified  slot. 

A  REPLY  message  is  sent  by  REPLY  and  RETURN  statements,  as  well  as  the  implicit  REPLY 
of  the  last  expression  of  the  method  code.  It  communicates  the  result  of  the  method  back  to 
the  caller. 
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msg| 

LoadCode 

Message  Length 
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Class 

2 

Selector 

3 

Code 

2+n 

Figure  B-5.  CODE  Message  Format 

The  CODE  message  contains  the  executable  code  for  a  method  along  with  the  method's  class  and 
selector. 

A  CODE  message  is  generated  by  the  compiler.  It  specifies  the  code  of  a  method.  CODE 
messages  are  not  directly  manipulated  by  Concurrent  Smalltalk  methods  other  than  methods 
that  are  part  of  the  operating  system. 
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A  Concurrent  Smalltalk  Compiler  for  the  Message-Driven  Processor 


Table  B-2.  System  Call  Specifications 


New_Context 

ENTRY: 

DESCRIPTION. 

REGISTERS  ALTERED: 
TASK  SWITCHING: 
EXIT: 


Fre*_Cortext 

ENTRY: 

DESCRIPTION: 

TASK  SWITCHING: 
REGISTERS  ALTERED: 


RO  contains  n,  the  number  of  local  variables  to  allocate. 

NewContext  alocales  a  new  context  with  n  locals  and  returns  the  context's  ID 
in  ID1  and  address  in  Al. 

R0.R1A1.ID1. 

Yes. 

IDl  contains  the  context  object's  ID. 

Al  points  to  (he  context  object 


IDl  contains  the  context  object's  ID. 

Al  points  to  the  context  object 

Free_Context  deallocates  the  context  and  returns  it  to  the  free  storage  pool. 

Yes. 

R0.R1A1.ID1. 


New_Object 

ENTRY: 

DESCRIPTION: 
REGISTERS  ALTERED: 
TASK  SWITCHING. 
EXIT: 


RO  contains  the  number  of  instance  variables  of  the  class. 

R1  contains  the  class  number. 

New_Object  allocates  a  new  object  of  the  specified  class  and  returns  it 
R0.R1. 

Yes. 

RO  contains  the  ID  of  the  new  object. 


Send_Node_Nr 

ENTRY: 

DESCRIPTION: 


REGISTERS  ALTERED: 
TASK  SWITCHING. 
EXIT: 


RO  contains  a  receiver  object. 

Send_Node_Nr  determines  a  node  to  which  a  SEND  message  involving  the  re¬ 
ceiver  object  should  be  sent.  If  the  receiver  object  is  atomic,  a  random  node  is 
returned.  If  it  is  a  true  object,  the  operating  system  tries  to  guess  the  node  on 
which  the  object  currently  resides. 

R0.R1. 

No. 

R1  contains  the  node  number  to  which  to  send  the  message. 


Divide 

ENTRY: 

DESCRIPTION: 


REGISTERS  ALTERED: 
TASK  SWITCHING: 
EXIT: 


RO  contains  the  divisor. 

R1  contains  the  dividend. 

Divide  calculates  R1//R0  and  R1  mod  RO  and  stores  the  quotient  in  RO  and  re¬ 
mainder  in  R1 .  An  error  occurs  if  R0=0.  The  quotient  is  rounded  towards  -«, 
so  5//3  has  quotient  1  and  remainder  2,  but  -5//3  has  quotient  -2  and  remainder 
1. 

R0,R1. 

Yes. 

RO  contains  the  quotient 
R1  contains  the  remainder. 


Task  switching  means  that  the  process  may  be  suspended  to  run  another  process  or  accept  a 
REPLY  message.  If  task  switching  is  not  allowed,  no  other  message  at  priority  level  0  may  be  pro¬ 
cessed. 
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The  Utilities  file  defines  data  types  and  functions  that  are  used  throughout  the  compiler.  The 
more  important  ones  are  listed  below. 


Bit  Sets 

The  bset  data  type  is  defined  in  the  Utilities  file.  A  bset  is  an  immutable  abstract  data  type 
that  represents  a  possibly  infinite  set  of  nonnegative  integers.  The  operations  allowed  on 
bsets  include  testing  for  the  empty  bset,  testing  an  integer  for  membership,  adding  and 
removing  integers,  finding  unions,  intersections,  differences,  and  complements  of  bsets, 
returning  the  lowest  integer  present  in  the  bset,  and  iterating  using  the  loop  facility  and 
mapping  over  the  members  of  bsets.  Note  that  with  these  operations,  the  only  possible  bsets 
that  can  be  created  are  either  finite  sets  or  complements  of  finite  sets. 

The  Lisp  reader  is  modified  to  accept  a  syntax  for  describing  bsets.  The  syntax  for  a  bset  is 

<bset>  ::=  #(  |o|i){  (<integer>  |  (<integer>  <integer>)  )*  ) 

The  digit  following  the  #  sign  specifies  whether  the  bset  is  a  finite  set  or  the  complement  of  a 
finite  set.  If  the  digit  is  missing  or  0,  the  bset  is  finite;  otherwise,  it  is  the  complement  of  a 
finite  set,  and  the  nonnegative  integers  not  in  the  set  are  listed.  After  the  optional  digit  is  the 
set  of  nonnegative  integers  in  (or  not  in)  the  bset  expressed  as  a  list  between  braces.  A  range 
of  consecutive  integers  may  be  specified  by  specifying  a  two-element  list  of  the  low  and  high 
integers,  inclusive.  Duplicate  integers  and  overlapping  ranges  are  allowed.  Some  examples 
of  bsets  are  listed  in  Table  C-l. 


Table  C-l.  Sample  Bsets 


Syntax 

#11  or #0(1 
#1(1 

# { 4  }  or  #{ (4  4) lor  #0 ( 4  4  4  4  4  4} 
#(1  2  8  9  3}  Or  #(  (13)  8  9} 

#1(3  5} 


Value 

The  empty  set  {} 

The  complete  set  {0,1, 2,3,...} 
The  set  {4} 

The  set  (1,2, 3, 8, 9} 

The  set  {0,1, 2,4,6, 7,8....} 


Bsets  are  implemented  as  either  integers  or  structures  depending  of  whether  ‘debug*  is  true. 
If ‘debug*  is  true,  bsets  are  implemented  as  structures,  which  has  the  dual  advantages  of 
having  bsets  print  in  the  readable  format  described  above  and  type-checking  operations  on 
bsets,  but  at  a  penalty  of  increased  garbage  collection  and  about  a  20%  decrease  in  speed  of 
the  compiler. 


FIFOs 

The  FIFO  data  type  defined  in  Utilities  is  an  implementation  of  a  first-in-first-out  queue.  A 
FIFO  can  be  created,  elements  can  be  added  to  the  end  of  it,  and  the  entire  FIFO  can  be 
returned  in  the  form  of  a  list  with  the  first  elements  listed  first,  all  in  constant  time. 
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Digraphs 


Figure  C-l.  Sample  Digraph. 

This  digraph  consists  of  a  root  and  five  nodes.  Note  that  node  4  is  not  reachable  with  a  depth-first 
traversal  of  the  digraph  originating  at  the  root.  Multiple  edges  between  a  pair  of  dinodes  are 
|  permitted,  as  between  nodes  1  and  3. 

The  Utilities  file  contains  an  extensive  implementation  of  directed  graphs  (digraphs).  A  digraph 
consists  of  zero  or  more  nodes  (dinodes)  and  a  root  structure  (the  digraph  structure  itself). 
The  root  structure  is  linked  to  zero  or  more  dinodes  that  are  called  “successors  of  the  root.” 
Each  dinode  is  given  a  unique  serial  number  to  identify  it  during  printing  a  digraph  and 
|  debugging  and  to  help  in  certain  digraph  operations.  Besides  the  serial  number,  each  dinode 

contains  links  to  all  of  its  predecessors  and  successors.  In  order  for  digraphs  to  be  useful  as 
an  implementation  of  flow  of  control  graphs  for  programs,  all  operations  are  careful  to 
preserve  the  order  of  successors  of  each  dinode.  This  way  the  “first”  successor  and  “second” 
successor  of  conditional  branch  nodes  are  never  transposed  by  digraph  operations,  which 
would  reverse  the  meaning  of  the  condition.  Every  digraph  must  be  connected — any  pieces 
[  not  connected  to  the  root  are  simply  garbage-collected  at  the  next  opportunity.  A  sample 

digraph  is  shown  in  Figure  C-l. 

Dinodes  and  digraphs  by  themselves  are  structures  that  contain  no  user  information.  These 
structures  are  meant  to  be  included  in  in  other  user-defined  structures  using  Common  Lisp's 
structure  :  include  facility.  This  is  the  way  stmts,  stmtgraphs,  insts,  and  modules  are 
|  implemented. 

Printing 

The  standard  Common  Lisp  printer  is  inadequate  in  printing  dinodes  and  digraphs  because 
digraphs  contain  numerous  circular  references.  Even  with  the  depth  and  length  limits  and 
circular  printing  enabled,  it  is  next  to  impossible  to  see  the  digraph  structure  from  the 
I  Common  Lisp  printer's  output.  Thus,  special  printing  procedures  were  defined  for  dinodes 

and  digraphs. 

A  dinode  is  printed  as  a  list  of  its  data  field  names  and  values  together  with  the  lists  of  the 
serial  numbers  of  the  successors  and  predecessors  of  the  dinode.  If  it  is  desired  to  see  the 
values  of  the  predecessor  or  successor  dinodes,  one  can  use  the  function  nth-dinode  to  find  in  a 
!  digraph  and  output  a  dinode  with  a  given  serial  number. 

A  digraph  is  printed  in  the  format 
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*<digraph  (<rootl>  ...  <rootn>)  { <set  of  tfinode  numbers> ) > 

The  tfgraph  is  printed  as  a  list  of  the  serial  numbers  of  the  dinodes  that  are  successors  of  the 
root  followed  by  the  serial  numbers  of  all  dinodes  in  the  digraph  printed  in  the  set  notation 
similar  to  that  used  by  bmaps. 

Low-Level  Operations 

The  low-level  operations  on  digraphs  include  creating  an  edge  between  two  nodes,  removing 
the  edge,  checking  whether  a  dinode  is  the  root,  testing  for  an  edge  between  two  nodes,  and 
traversing  the  digraph  in  depth-first  order.  Whenever  the  structure  of  a  digraph  is  altered 
directly  or  with  a  low-level  operation,  altered-digraph  should  be  called  to  cause  some  data 
structures  pertaining  to  the  digraph  to  be  recalculated. 

Medium-Level  Operations 

The  medium-level  operations  on  digraphs  deal  with  the  structure  of  more  than  just  one  or  two 
nodes.  These  include  inserting  a  new  node  in  the  place  of  an  existing  edge  (Figure  C-2a), 
inserting  a  new  node  before  an  existing  one  (Figure  C-2b),  deleting  a  node  (Figure  C-3),  and 
merging  two  nodes  into  one  (Figure  C-4). 


Figure  C-2.  Inserting  a  New  Digraph  Node. 

(a)  shows  the  effect  of  insert-dinode.  A  new  dinode  numbered  7  is  inserted  in  place  of  an  existing 
edge  between  existing  dinodes  6  and  3. 

(b)  shows  the  effect  of  insert-before-dinode.  The  new  dinode  (7)  is  inserted  before  an  existing  one 
(3),  and  all  of  3‘s  predecessors  are  linked  to  the  new  dinode  instead. 


A  Concurrent  Smalltalk  Compiler  for  the  Message-Driven  Processor 


Figure  C-3.  Deleting  a  Digraph  Node. 

(a)  and  (b)  both  show  the  effect  of  calling  delete-dinode  on  dinode  7.  The  connections  between 
existing  dinodes  and  the  deleted  dinode  are  transferred  to  the  deleted  dinode's  predecessors  and 
successors. 


Figure  C-4.  Merging  Digraph  Nodes. 

Dinodes  7  and  8  are  merged  by  calling  merge-dinode.  All  of  7's  and  8‘s  predecessors  now  connect 
to  7. 

A  predicate  medium-level  operation  is  also  available  that  tests  whether  two  dinodes 
connected  by  an  edge  are  in  the  same  basic  block  of  the  digraph.  A  basic  block  of  a  digraph  is 
defined  as  a  chain  of  nodes  in  which  each  node  except  the  last  has  only  one  successor,  the 
next  node  in  the  chain,  and  each  node  except  the  first  has  only  one  predecessor,  the  previous 
node  in  the  chain. 

Useful  global  medium-level  operations  include  disconnecting  all  nodes  that  are  not  reachable 
by  following  edges  from  the  root  (Figure  C-5),  combining  basic  blocks  into  single  nodes  with  a 
combinator  function,  and  deleting  all  nodes  that  satisfy  a  given  test  from  the  digraph. 
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Figure  C-5.  Purging  Unreachable  Digraph  Nodes. 

Dinodes  4  and  5  are  not  reachable  from  the  root  of  the  digraph,  so  purge-unreachables-digraph 
disconnects  them  from  the  rest  of  the  digraph.  This  operation  is  important  for  eliminating  dead  code 
and  for  ensuring  consistency  in  algorithms  that  follow  digraph  edges  in  reverse. 


High-Level  Operations 

The  high-level  operations  on  digraphs  perform  powerful  macroscopic  functions  on  the  directed 
graphs.  One  such  function,  map-digraph,  maps  a  digraph  onto  a  new  digraph  by  calling  a 
mapping  function  for  each  node  of  the  original  digraph.  The  mapping  function  is  allowed  to 
return  an  arbitrary  piece  of  a  digraph,  whether  it  be  null,  a  single  dinode,  or  many  dinodes 
linked  together. 

Another  high-level  operation  returns  the  digraph’s  blockgraph.  A  blockgraph  is  another 
digraph  in  which  each  node  represents  and  points  to  an  entire  basic  block  of  the  original 
digraph. 

The  high-level  digraph  operation  that  is  used  the  most  is  the  general  relaxation  algorithm  for 
digraphs.  A  routine,  micro-relax,  solves  a  relaxation  problem  of  one  of  the  forms: 

Forward: 

OutValue(root)=R 

Vdinode  d:  InValue(d)  =  combinator(OutValue(pred1) . OutValue(predn)), 

where  predl , predn  are  d's  predecessors 
Vdinode  d:  OutValue(d)  =  f(lnValue(d)) 

Backward : 

Vdinode  d:  OutValue(d)  =  combinatortlnValuetsuccI), ....  InValue(succn)), 
where  succl, ....  succn  are  d's  successors 
Vdinode  d:  InValue(d)  =  f(OutValue(d)) 

The  algorithm  used  is  similar  to  that  described  on  page  691  of  [2].  The  algorithm  proceeds  by 
assigning  an  initial  value  to  all  of  the  dinodes.  The  initial  values  are  important,  as  they 
determine  the  solution  chosen  when  there  are  multiple  solutions.  It  then  iterates,  calling  f 
and  combinator,  over  the  entire  digraph  until  the  dinodes'  values  converge  to  a  solution.  The 
nodes'  values  are  calculated  in  either  the  depth-first  order  or  the  reverse  of  the  depth-first  or¬ 
der,  so  as  to  maximize  the  speed  of  the  convergence.  It  can  be  shown  that  for  the  functions  f 
and  combinator  used  in  the  compiler  (f (x)  =  (XAa)vb,  combinator  is  either  a  or  v  of  the 
arguments),  the  relaxation  algorithm  will  always  converge  to  a  solution. 
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Relax  is  a  variant  of  micro-relax  that  first  computes  the  blockgraph,  performs  the  iterative 
algorithm  on  the  blockgraph,  and  then  calculates  the  values  for  the  original  digraph.  Relax 
may  be  faster  than  micro-relax  on  digraphs  containing  many  loops. 

Calc-dominators  calculates  the  dominators  of  each  dinode.  A  node  A  is  a  dominator  of  node 
BM  if  every  path  firom  the  root  to  B  must  pass  through  A. 

Finally,  linearize  is  a  function  that  returns  a  list  of  the  nodes  of  the  digraph  in  an  order  that 
attempts  to  minimize  the  number  and  length  of  branches ,  where  a  branch  is  an  edge  from  a 
dinode  to  a  dinode  that  does  not  follow  it  in  the  list  that  is  output  Linearize  uses  heuristics 
such  as  listing  all  of  the  dominators  of  a  dinode  before  the  dinode  and  keeping  track  of  the 
loops  encountered  in  the  digraph  and,  when  a  loop  has  been  entered,  assigning  priority  to 

listing  dinodes  in  the  loops  before  dinodes  outside  the  loops. 
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» 

r 

i 

i 

*  tt* 

;  CST  Compllar  ;;; 

i 

! 

•  tit 

;  version  1.3  ;;; 

• 

t 

t  tit 

;  written  by  ;;; 

* 

;  Waldemar  Horwat  ;;; 

i 

t 

1  tit 

;  Bachelor's  thesis  under  Prof.  William  Dally  ;;; 

i 

l 

1  III 

;  January  21,  1988  ;;; 

1 

;  April  30,  1988 

f 

§ 

t  III 

;  Send  problems  and  comments  to 

s 

;  waldamar8vx.lci.mit.edu.  ;;; 

1 

t 

•  iii 

;  Copyright  1988  Waldemar  Horwat  ;;; 

t  Sit 

$ 

lllllllltlllllltlfllltllllllttltllliililillilllii 

;;;Return  t  if  the  list  1  has  zero  or  one  element, 
(defmacro  one-elt-p  (1) 

' (null  (cdr  ,1)1) 


.’.’.-Return  true  if  x  and  y  are  not  eql.  ,  fj 

(defun  neql  (x  y)  (not  (eql  x  y) ) ) 

;;;Return  true  if  x  and  y  are  not  equal. 

(defun  nequal  (x  y)  (not  (equal  x  y) ) ) 


;; (all-tuples  (<eltl  elt2  ...  eltn)  <llst-expr>) 

? ;  stmts...) 

.’.'Given  a  list  1,  iterate  variables  eltl,  elt2,  ....  eltn  through  all  unordered 

;;n-tuples  of  elements  of  1.  Execute  stmts  with  eltl,  ....  eltn  bound  to  elements  of  1.  _1 

(defmacro  all-tuples  ((((rest  elts)  1)  (body  code) 

(let  ( (elt  (car  elts))) 

(cond 

( (null  elts) ) 

( (endp  (cdr  elts) ) 

‘ (dollst  (,elt  ,1)  , Scode) > 

(t 

(let  ((eltsl  (gensym))) 

(do  ((.eltsl  ,1  (cdr  .eltsl))) 

( (endp  .eltsl) ) 

(let  ((.elt  (car  .eltsl))) 

(all-tuples  (, (cdr  elts)  (cdr  .eltsl))  .Scode)))))))) 


;;;Prlnt  the  list  of  Integers  obtained  by  applying  generator  to  successive  elements  of 
;;;lst.  The  printed  output  Is  enclosed  in  brackets,  and  ranges  of  consecutive  Integers 
;;;are  abbreviated  with  ..'s. 

|  ;;;For  Instance,  If  the  function  Is  ('Identity  and  1st  is  1  (1  2  4  5  7  8  9),  the  output  1 

; ; ; w  1 1 1  be  ( 1  2  4  5  (7  9)  I . 

(defun  prlnt-range-list  (generator  1st  (optional  (stream  t)) 

(flet  ( (prlnt-rangeend  (first  last) 

(format  stream  "~(-D-;-D  -D~:;(-D  -D)-)“  (-  last  first)  first  last))) 

(wrlte-char  (\(  stream) 

(do  ((last  nil) 

(rangebegln  nil) 

(remaining  1st  (cdr  remaining))) 

|  ((null  remaining)  (If  last  (prlnt-rangeend  rangebegln  last)))  _1 

(let  ((num  (funcall  generator  (car  remaining)))) 

(cond  ((null  last) 

(setq  rangebegln  num)) 
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( (/-  num  (1+  last) ) 

(print -rangeend  rangebegin  last) 
(wrlts-char  #\Space  stream) 

(setg  rangebegln  num))) 

(setq  last  num) ) ) 

(write-char  *\)  stream) 

(values))) 


;;;Get  the  value  of  an  attribute  from  an  association  list.  If  It  Is  not  present, 
;;;calculate  It  using  the  calculator  expression  and  add  it  to  the  association  list. 
;;;Return  the  value  of  the  attribute. 

(defmacro  attribute  (name  assoc-llst  calculator) 

(let  ((value  (gensym) ) 

(new-value  (gensym))) 

'(let  ((.value  (assoc  ,name  ,  assoc-list) ) ) 

(if  , value 
(cdr  , value) 

(let  ((, new-value  .calculator)) 

(push  (cons  .name  , new-value)  .assoc-list) 

.new-value) ) ) ) ) 

;;;Perform  action  until  It  does  not  clear  the  attributes. 

(defmacro  attribute-steady-state  (assoc-list  action) 

(let  ((name  (gensym))) 

' (loop  do  (progn 

(unless  (assoc  '.name  .assoc-list)  (push  '(.name)  .assoc-list)) 

, action) 

until  (assoc  ‘.name  .assoc-list)))) 


;;;Return  the  floor  of  the  base-2  logarithm  of  positive  integer  n. 

;;;Return  nil  if  n  is  zero  or  negative. 

(defun  log2  (n) 

(and  (>  n  0)  (1-  (integer-length  n)))) 

;;;Return  true  if  integer  n  is  a  power  of  2. 

(defun  power-of-2?  (n) 

(and  (>  n  0)  (eql  n  (ash  1  <log2  n) ) ) ) ) 

- + 

;;;,•)  BitMap  i 
; ■ ; ;+ — + 

;;;A  bmap  Is  a  bitmap  of  the  variables.  Implemented  as  an  integer  or  a  structure  depending 
;;; on  whether  ‘debug*  is  true. 

;;;The  following  operations  are  defined: 

(eval-when  (compile  load  eval) 

(If  ‘debug* 

(progn 

(fresh-line) 

(wrlte-llne  “;bmap  is  a  structure.") 

(defstruct  (bmap  (:prlnt-functlon  print -bmap!)  bits) 

(defmacro  lnt-to-bmap  (1)  ' (maVe-bmap  :bits  ,1)) 

(defmacro  bmap-to-lnt  (b)  ' (bmap-blts  ,b))) 

(progn 

(deftype  bmap  ()  ’integer) 

(defmacro  lnt-to-bmap  (1)  1) 

(defmacro  bmap-to-lnt  (b)  b) ) ) ) 


(defconstant  bO  (int-to-bmap  0))  ;The  empty  bset. 

(defconstant  bl  (lnt-to-bmap  -1))  ;The  complete  bset. 

;;;Return  true  If  the  bmap  Is  empty. 

(defmacro  bempty  (bmap) 

' (zerop  (bmap-to-lnt  ,bmap))) 

;;;Hake  a  L-ip  with  bits  from  low-bit  (Inclusive)  to  hlgh-blt  (exclusive)  set. 
;;;Low-bit  defaults  to  zero. 

(defmacro  brange  (hlgh-blt  toptlonal  low-bit) 

(list  ■  lnt-to-bir.ip 

(If  low-bit  '  (-  (1-  (ash  1  .hlgh-blt))  (1-  (ash  1  , low-bit))) 

(1-  (ash  1  , hlgh-blt )))) ) 

;;;Return  non-nil  If  variable  n  Is  In  the  bmap. 

(defmacro  htest  (n  bmap) 

'  (logbltp  ,n  (bmap-to-lnt  .brnap))) 

;;;Add  variable  n  to  the  bmap.  If  bmap  Is  missing,  return  a  bmap  with  only 
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;; (variable  n  set . 

(defmacro  baat  (n  (optional  bmap) 

(Hat  'lnt-to-bmap 
(If  bnap 

" (loglor  (ash  1  ,n)  (bmap-to-lnt  .bmap)) 

' (ash  1  ,n) ) ) ) 

(daf ina-modify-macro  baatf  (n)  (lambda  (bnap  n)  (bset  n  bnap))) 

;; (Remove  variable  n  from  the  bnap. 

(defmacro  bclr  (n  bnap) 

‘ (lnt-to-bnap  (logandcl  (ash  1  ,  n)  (bmap-to-lnt  .bnap)))) 

(daf lne-modlfy-macro  bclrf  (n)  (lambda  (bnap  n)  (bclr  n  bnap))) 

(((Return  tha  lowest-numbered  variable  greater  than  or  equal  to  low  In  the  bmap 
;;;or  nil  If  the  bnap  Is  empty. 

(defun  blow  (bmap  (optional  (low  0)) 

(cond  Hand  (>-  (bmap-to-lnt  bmap)  0)  (<  (bmap-to-lnt  bnap)  (ash  1  low)))  nil) 

( (btest  low  bmap)  low) 

(t  (blow  bmap  (1+  low) ) ) ) ) 

;;;Return  tha  union  of  the  boaps. 

(dafmacro  b+  ((rest  bmaps) 

(list  'lnt-to-bmap 
(cons  'loglor 

(mapcar  ('(lambda  (Dmap)  (list  'bnap-to-lnt  bnap))  bmaps)))) 

;;;Return  the  intersection  of  the  bmaps. 

(defmacro  b*  ((rest  bmaps) 

(list  ' lnt-to-bmap 
(cons  'logand 

(mapcar  ('(lambda  (bmap)  (list  'bnap-to-lnt  bnap))  bmaps)))) 

;;;Return  the  difference  of  two  bmaps. 

(dafmacro  b-  (bmapl  bmap2) 

'(lnt-to-bmap  (logandc2  (bmap-to-lnt  .bmapl)  (bmap-to-lnt  ,bmap2)))) 

;;;Return  the  complement  of  the  bmap. 

(defmacro  bnot  (bmap) 

'(lnt-to-bmap  (lognot  (bmap-to-lnt  .bmap)))) 

;;;Return  the  union  of  the  results  of  the  function  f  applied  to  the  elements  of  the  list  1. 
(defun  map-b+  (f  1) 

(do  ((1st  1  (cdr  1st)) 

(result  bO  (b+  (funcall  f  (car  1st))  result))) 

((endp  1st)  result))) 

;; .'Return  the  Intersection  of  the  results  of  tha  function  f  applied  to  the  elements  of  the  list 
(dafun  map-b*  (f  1) 

(do  ((1st  1  (cdr  1st)) 

(result  bl  (b*  (funcall  f  (car  1st))  result))) 

((endp  1st)  result))) 


;;Add  mapping  over  variables  of  a  bmap  to  the  loop  macro. 

;;The  format  Is: 

IS  (loop  for  <blt-var>  being  the  bits  of  <bmap>  ...) 

;;<blt-var>  gets  assigned  to  each  set  bit  of  <bmap>.  The  order  is  not  specified. 

(def lne-loop-path  bits  blts-path  (of)) 

(defun  blts-path  (path-name  variable  data-type  prep-phrases  Inclusive?  allowed-prepositlons  data) 
(declare  (Ignore  path-name  data-type  allowed-preposltirns  data)) 

(let  ( (of-phrase  (loop-tassoc  ‘of  prep-phrases)) 

(bmap  (gensym) ) ) 

(cond 

((null  of-phrase)  (error  "OF  missing1')) 

(Inclusive?  (error  "Inclusive  Iteration  path  not  supported”))) 

(list 

(list  (list  variable  -1) 

(cons  bmap  (cdr  of-phrase))) 

nil 

nil 

(list  variable  (blow  ,bmap  (1+  .variable))) 

*  (null  .variable) 
nil))) 


(eval-when  (compile  load  aval) 

(when  "debug* 

(defun  print-bmap  (bmap  stream  depth) 
(declare  (Ignore  depth)) 

(wrlte-char  #\l  stream) 
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(lat  ((bits  (bmap-to-lnt  bmap))) 

(whan  (<  bits  0) 

(writa-char  *\1  straam) 

(setq  bits  (lognot  bits))) 

(print-range-list  ••identity 

(loop  f or  i  being  the  bits  of  (int-to-bmap  bits)  collect  1) 
stream) ) ) ) ) 


;;; Allow  printed  boaps  to  be  read  back  in  by  the  reader. 

(eval-when  (compile  load  aval) 

(defun  hasp-reader  (stream  char  arg) 

(declare  (ignore  char) ) 

(let  ((bits  b0)) 

(dolist  (num  (read-dellmlted-llst  »\)  stream  t) ) 

(cond 

((intagerp  num)  (bsetf  bits  num)) 

( (consp  num) 

(let  ((nl  (first  num)) 

(n2  (second  num) ) ) 

(if  (and  (intagerp  nl) 

(intagerp  n2) 

(nul 1  (cddr  num) ) ) 

(setq  bits  (b+  bits  (if  (>-  nl  n2)  (brange  (1+  nl)  n2) 
(brange  (1+  n2)  nl)))) 

(error  "Bad  hasp  range:  -S*  num) ) ) ) 

(t  (error  "Bad  boap  bit:  -S*  num)))) 

(if  (and  arg  (>  arg  0)) 

(setq  bits  (bnot  bits))) 
bits)) 

(set-dispatch-macro-character  «\#  #\(  t 'bmap- reader) 
(set-macro-character  »\ ) 

•' (lambda  (stream  char) 

(declare  (Ignore  stream  char)) 

(error  "Bad  bmap  specif lest Ion") ) 
nil)) 


;;;;+ - + 

I  fifo  i 

;;;;+ - + 

(deftype  fifo  ()  'cons) 

;; .-Create  a  new  FIFO  queue  from  the  given  data  list. 

(defun  new-flfo  (^optional  data) 

(if  (null  data) 

(let  ((n  (cons  nil  nil))) 

(setf  (car  n)  n) 
n) 

(cons  (last  data)  data))) 

;;;Return  the  flfo'a  data  as  a  list. 

(defmacro  flfo-data  (fifo) 

'  (edr  , fifo) ) 

;;;Return  the  flfo'a  last  element  or  nil  If  there  Isn't  any 
(defun  flfo-tall  (fifo) 

(if  (eq  (car  fifo)  fifo) 
nil 

(caar  fifo) ) ) 

;;;Add  an  element  to  the  end  of  a  fifo. 

(defun  add-flfo  (fifo  element) 

(let  ((pair  (cons  element  nil))) 

(setf  (edar  fifo)  pair) 

(setf  (car  fifo)  pair) 
fifo)) 


;  t - - - + 

?l  A  digraph  node  I 
; + - ♦ 

(d 1  node-predecessors  dlnode)  Is  a  list  of  the  dinode's  predecessors.  The  order  Is  not 
Important.  A  nil  predecessor  Indicates  the  head  of  the  digraph. 

(dlnode-successors  dlnode)  Is  a  list  of  the  dlnode's  successors.  The  order  Is 
Important — for  conditional  branches,  the  first  successor  is  the  fall-through 
destination,  while  the  second  successor  is  the  branch  destination. 

(dlnode-serlal-number  dlnode)  la  a  serial  number  of  the  dlnode  for  debugging  purposes, 
(dlnode-mark  dlnode)  Is  a  mark  temporary  used  for  searching  the  digraph. 

(dlnode-spare  dlnode)  Is  a  spare  value  used  by  map-digraph. 
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;;;?here  Is  no  data  [laid;  tha  dinodea  are  meant  to  be  uaed  aa  part  o f  larger  record*  with 
;; /other  data  field*. 

(defvar  current-aerlal-number  0) 

(def struct  (dinode  (/print-function  prlnt-dinode) ) 

(aerial-number  (aatq  current-aerial-number  (1+  current-aerial-number))  /read-only  t) 

mark 

spare 

predecessors 

successors) 


;;;Return  a  list  representation  of  the  dinode's  data. 

(defun  prlntdata-dinode  (dlnode) 

(list 

(dinode-serial-number  dinode) 

(cons  • predecessors 

(mapcar  # 'dinode-aerial-number  (dinode-predecessors  dlnode))) 
(cons  'successors 

(mapcar  ('dinode-serlal-number  (dinode-successors  dlnode))))) 
;;;Prlnt  the  dlnode. 

(defun  prlnt-dinode  (dlnode  stream  depth) 

(declare  (ignore  depth)) 

(print  (cons  'dlnode  (prlntdata-dinode  dlnode))  stream)) 


;;;Replace  the  first  occurence  of  old  in  data  with  new-llst  spliced  into  data. 

;;; A  new  data  is  returned;  the  alteration  is  nondestructive. 

;;;An  error  is  given  if  old  is  not  found  in  data. 

(defun  subst -append-1  (data  old  new-list) 

(cond 

((null  data)  (error  "Old  not  found  in  data  in  subst -append-1") ) 

( (eq  (car  data)  old)  (append  new-list  (cdr  data))) 

(t  (cons  (car  data)  (aubst-append-1  (cdr  data)  old  new-list))))) 

;;; (Subst-append-lf  data  old  new-list)  sets  the  generalized  variable  data  to  be  the 
;;; (subst-append-1  data  old  new-list). 

(deflne-modify-macro  subst -append-lf  (old  new-llst)  subst-append-1) 


;;;Llnk  the  from  dlnode  to  the  to  dlnode. 

;;;» o  check  is  made  for  duplicate  links, 

(defun  link-dlnode  (from  to) 

(setf  (dinode-successors  from)  (nconc  (dinode-successors  from)  (list  to))) 
(push  from  (dl node-predecessors  to) ) ) 


;;Unllnk  the  from  dinode  from  the  to  dlnode.  The  link  must  have  been  present. 
;;If  there  was  more  than  one  link  from  the  from  dlnode  to  the  to  dlnode,  only  one 
;;llnk  is  removed. 

(defun  unllnk-dlnode  (from  to) 

(subst-append-lf  (dinode-successors  from)  to  ’ () ) 

(subst-append-lf  (dlnode-predecessors  to)  from  '())) 


///Return  true  if  the  from  dlnode  Is  linked  to  the  to  dlnode. 
(defun  dlnodes-llnked-p  (from  to) 

(find  to  (dinode-successors  from))) 


III* - ♦ 

III  I  A  digraph  I 
III* - + 

//A  digraph  Is  a  collection  of  dinodes  with  a  digraph  header. 

/ / (digraph-successors  digraph)  Is  the  list  of  the  head  dinodes  of  the  digraph. 

/; (digraph-mark  digraph)  is  an  Integer  such  that  none  of  the  dlnodes  in  the  digraph  has 
;;  a  mark  greater  than  to  (digraph-mark  digraph). 

//(digraph-attributes  digraph)  Is  an  association  list  of  Information  about  the  digraph 
/;  that  la  cleared  every  time  the  digraph  Is  altered.  The  list  includes: 

;;  (digraph-df 1 1st  <llst>),  a  depth-first  ordered  list  of  the  digraph's  nodes/ 

;;  (dlgraph-reverse-dfl 1st  <llst>),  the  reverse  of  dlgraph-dfllst; 

//  as  well  as  other  user-defined  Items. 

(defstruct  (digraph  (/Include  dlnode  (serial-number  nil)  (mark  0)) 

(/print-function  print -digraph) ) 

attributes 

dflist 

reverse-df list) 


//Return  a  list  representation  of  the  digraph's  data. 

(defun  prlntdata-dlgraph  (digraph) 

(list  (mapcar  • 'dinode-serlal-number  (digraph-successors  digraph)) 
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(mapcar  * ' dinode-serial-number  (digraph-dfs  digraph) ))) 
;;Prlnt  the  digraph. 

(defun  print -digraph  (digraph  stream  depth) 

(declare  (ignore  depth)} 

(prinl  (cons  'digraph  (prlntdata-digraph  digraph))  stream)) 


(defun  print-digraph-data  (digraph  stream) 

(format  stream  *~S  "  (mapcar  f • di node-serial-number  (digraph-successors  digraph))) 
(print-range-list  # 'dinode- serial -number  (digraph-dfs  digraph)  stream)) 

;;;Prlnt  the  digraph. 

(defun  print-digraph  (digraph  stream  depth) 

(declare  (Ignore  depth) ) 

(write-string  "#<Digraph  •  stream) 

(print-digraph-data  digraph  stream) 

(write-char  #\>  stream)) 


;;;Return  true  if  the  dlnode  is  actually  the  root  of  the  digraph, 
(defmacro  root?  (dlnode) 

‘(null  (d inode- serial -number  ,dinode))) 

(defmacro  non-root?  (dinode) 

’  (d inode- serial -number  , dinode)) 


;;;Create  a  new  digraph  with  the  given  dinodes  as  successors  of  the  root. 

;;;lf  root  is  non-nil,  it  is  used  as  the  root  of  the  digraph;  otherwise,  a  new 
;;;root  is  created. 

(defun  new-digraph  (root-successors  aoptional  root) 

(let  ((graph  (or  root  (make-digraph)))} 

(dollst  (successor  root-successors  graph) 

( link-dinode  graph  successor)))) 


;;;Mark  the  digraph  as  altered. 

(defun  altered-dlgraph  (digraph) 

(setf  (digraph-attributes  digraph)  nil)) 


;;;Return  a  depth-first  ordered  list  of  the  digraph's  nodes. 

;;;If  ;from-end  is  non-nil,  return  the  list  in  reverse  order. 

(defun  digraph-dfs  (digraph  4 key  from-end) 

(if  from-end 
(attribute 

'reverse-dflist  (digraph-attributes  digraph) 

(reverse  (digraph-dfs  digraph))) 

(attribute 

'dfllst  (digraph-attributes  digraph) 

(let  ((mark  (1+  (digraph-mark  digraph)))) 

(labels 

( (dfs  (dlnode) 

(unless  (eql  (dinode-mark  dlnode)  mark) 

(setf  (dlnode-mark  dlnode)  mark) 

(cons  dlnode  (mapcan  I 'dfs  (dinode-successors  dinode)))))) 
(cdr  (dfs  digraph})))}}) 


;;;Call  function  f  on  each  dlnode  in  the  digraph  in  depth-first  order. 

;;;If  from-end  is  non-nil,  call  function  f  in  the  reverse  of  the  depth-first  order. 
;;;If  order  is  non-nil,  call  function  f  on  the  nodes  present  in  the  order  list, 
(defun  all-di nodes  (digraph  f  4key  from-end) 

(nape  f  (digraph-dfs  digraph  ; from-end  from-end))) 


;;Add  mapping  over  digraphs  to  the  loop  macro. 

;;The  format  is: 

;;  (loop  for  <node-var>  being  the  dlnodes  of  <digraph>  [:from-end  <bool-expr>)  ...) 

<node-var>  gets  assigned  to  each  dinode  of  <digraph>  in  depth-first  order 
;;or  the  reverse  of  the  depth-first  order  if  : from-end  is  specified  and  has  a  non-nil  value, 
(define- loop-path  dlnodes  dinodes-path  (of  : from-end)) 

(defun  dinodes-path  (path-name  variable  data-type  prep-phrases  inclusive?  allowed-prepositions  data) 
(declare  (ignore  path-name  data-type  allowed-prepositions  data)) 

(let  ( (of-phrase  (loop-tassoc  'of  prep-phrases)) 

(from-end-phrase  (loop-tassoc  : from-end  prep-phrases)) 

(cursor  (gensym) ) ) 

(cond 

((null  of-phrase)  (error  "OF  missing")) 

(Inclusive?  (error  "Inclusive  Iteration  path  not  supported"))) 

(list 
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(list  (list  variable) 

(list  cursor  ’ (digraph-dfs  ,  (cadr  of-phrase)  :from-end  , (cadr  f rom-end-phrase) ) ) ) 
nil 

*  (null  , cursor) 

nil 

nil 

(list  variable  * (car  f cursor ) 

cursor  * (cdr  , cursor))))) 


;; /Return  the  node  in  the  digraph  with  serial  number  n,  if  any. 
///This  function  Is  intended  for  debugging. 

(defun  nth-dinode  (digraph  n) 

(find  n  (dlgraph-dfs  digraph)  :key  I  *  dinode-serial-number) ) 


;;;Purge  any  unreachable  dinodes  from  the  digraph. 

;;;Thls  routine  works  by  examining  the  marks  left  from  the  last  dlgraph-dfs?  hence,  the 
?;;marks  or  the  digraph  should  not  be  modified  since  the  last  call  to  dlgraph-dfs. 
(defun  purge-unreachables-digraph  (digraph) 

(loop  for  dinode  being  the  dinodes  of  digraph  do 
(setf  (dinode-predecessors  dinode) 

(delete-if  I' (lambda  (predecessor) 

(and  predecessor  (not  (eql  (dlnode-mark  predecessor) 

(digraph-mark  digraph) ) ) ) ) 

(di node-predecessors  dinode)))) 

digraph) 


;;;Check  if  the  dinode  is  linked  to  itself.  If  so,  remove  all  such  links  and  return  true; 
;;;otherwlse,  return  false. 

(defun  unlink-self-dinode  (dinode) 

(when  (dinodes-linked-p  dinode  dinode) 

(uni ink-dinode  dinode  dinode) 

(unlink-self-dinode  dinode) 
t)) 


;; /Destructively  delete  a  dinode  from  a  digraph,  connecting  Its  predecessors 
;;;to  its  successors. 

{defun  delete-dinode  (dinode) 

(unllnk-self-dinode  dinode) 

(dolist  (predecessor  (dinode-predecessors  dinode)) 

(subst -append- If  (dinode-successors  predecessor)  dinode  {dinode-successors  dinode))) 
(dolist  (successor  (dinode-successors  dinode)) 

(subst-append-lf  (dinode-predecessc:s  successor)  dinode  (dinode-predecessors  dinode))) 
(setf  (dinode-predecessors  dinode)  nil) 

(setf  (dinode-successors  dinode)  nil)) 


;; /Insert  new-dinode  between  pred-dinode  and  succ-dinode,  breaking  the  link  between 
;; /pred-dinode  and  succ-dinode. 

(defun  Insert-dinode  (new-dinode  pred-dinode  succ-dinode) 

(subst-append-lf  {dinode-successors  pred-dinode)  succ-dinode  (list  new-dinode)) 
(subst-append-lf  (dinode-predecessors  succ-dinode)  pred-dinode  (list  new-dinode)) 
(setf  (dinode-predecessors  new-dinode)  (list  pred-dinode)) 

(setf  (dinode-successors  new-dinode)  (list  succ-dinode))) 


;; /Insert  new-dinode  in  front  of  dinode,  linking  new-dinode  with  all  of  dinode* s  predecessors 
;;;and  dinode  as  the  successor. 

(defun  Insert-before-dinode  (new-dinode  dinode) 

(dolist  (predecessor  (dlnode-predecessors  dinode)) 

(subst-append-lf  (dinode-successors  predecessor)  dinode  (list  new-dinode))) 

(setf  (dlnode-predecessors  new-dinode)  (dinode-predecessors  dinode)) 

(setf  (dinode-successors  new-dinode)  (list  dinode)) 

(setf  (dlnode-predecessors  dinode)  (list  new-dinode))) 


///Merge  dinodel  with  dlnode2.  The  successor  of  the  result  is  dinodel 's  successor.  The 
;/ /predecessors  are  the  union  of  the  two  dinodes1  predecessors. 

(defun  merge-di nodes  (dinodel  dinode2) 

(dolist  (successor  (dinode-successors  dinode2)) 

(unlink-dinode  dlnode2  successor)) 

(dolist  (predecessor  (dinode-predecessors  dinode2) ) 

(subst-append-lf  (dinode-successors  predecessor)  dinode2  (list  dinodel))) 

(setf  (dlnode-predecessors  dinodel) 

(append  (dlnode-predecessors  dinodel)  (dinode-predecessors  dlnode2))) 

(setf  (dlnode-predecessors  dlnode2)  nil)) 
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;; Destructively  concatenate  sequences  of  dtnodea  in  the  digraph  using  the  concatenates 
;;function  to  combine  the  dinodes.  Return  the  digraph. 

;;The  cornbinator  function  must  alter  the  structure  of  its  first  dinode  argument  to  combine 
;;it  with  the  second  dinode. 

(defun  combine- digraph  (digraph  cornbinator) 

(loop  for  dinode  being  the  dinodes  of  digraph  do 

(let  ((predecessor  (car  (dinode-predecessors  dinode}))) 

(when  (and  predecessor 

(one-elt-p  (di node-predecessors  dinode)) 

(one-elt-p  (dinode-successors  predecessor))) 

(funcall  cornbinator  predecessor  dinode) 

(delete-dinode  dinode) 

(altered-digraph  digraph) ) ) ) 

digraph) 


;; /Destructively  remove  empty  dinodes  from  the  digraph,  collapsing  the  structure  of  the 
;; /digraph  as  nodes  are  removed.  The  empty  function  decides  whether  a  dlnode  is  empty. 
;; /Nodes  with  more  than  one  successor  should  not  be  flagged  as  empty. 

;; /Return  the  digraph. 

(defun  delete-dlnode-if  (digraph  empty) 

(loop  for  dinode  being  the  di nodes  of  digraph  do 
(when  (funcall  empty  dlnode) 

(delete-dinode  dinode) 

(altered-digraph  digraph))) 

digraph) 


//Create  a  new  digraph  which  is  a  mapping  of  the  current  one.  The  mapping  function  map, 
//passed  as  a  parameter,  takes  a  single  argument  which  is  a  node  of  the  current  digraph. 
//It  returns  two  values/  the  first  one  is  a  starting  dinode,  while  the  second  one  is  a 
//list  of  ending  dinodes.  Map-digraph  maps  each  dlnode  in  the  original  digraph  into  a 
//new  digraph  with  the  mapping  function  determining  what  each  dinode  maps  into. 

//Map  may  graph  a  dinode  into  nothing  by  returning  two  nils.  Two  restrictions  apply  when 
//it  does  this: 

;/  No  loops  of  empty  nodes  may  be  created. 

? /  A  dinode  may  not  map  into  nothing  if  it  has  more  than  one  successor. 

//Return  the  new  digraph. 

//If  order  is  present,  it  must  be  a  list  of  the  digraph's  nodes.  Map  is  called  in  the 
//order  specified  by  order. 

(defun  map-digraph  (digraph  map  skey  order) 

//First  find  the  mapping  of  each  dinode  and  store  it  in  spare.  If  the  dinode  maps  into 
//nothing,  replace  It  with  a  dummy  dinode  indicated  by  a  t  in  its  spare  variable. 

(dolist  (dinode  (or  order  (digraph-dfs  digraph))) 

(multiple-value-bind  (first  last)  (funcall  map  dlnode) 

(if  first 

(setf  (dinode-spare  dinode)  (cons  first  last) ) 

(let  ( (dummy- d inode  (make-dinode  /spare  t))) 

(setf  (dinode-spare  dlnode)  (list  dummy-d inode  dummy-dinode) ) ) ) ) ) 

//Now  join  the  mapped  dinodes  to  each  other. 

(loop  for  dinode  being  the  dinodes  of  digraph  do 

(dolist  (successor  (dlnode-successors  dlnode)) 

(dolist  (final-node  (edr  (dinode-spare  dinode))) 

(llnk-dinode  final-node  (car  (dlnode-spare  successor) ) ) ) ) ) 

//Finally  initialize  the  new  digraph  and  remove  the  dummy  mapped  dinodes. 

(let  ((newgraph  (make-digraph))) 

(dolist  (successor  (digraph-successors  digraph) ) 

(llnk-dinode  newgraph  (car  (dlnode-spare  successor)))) 

(delete-d inode- if 
newgraph 

f 'dlnode-spare) ) ) 


//Return  true  if  successor  and  predecessor  are  nodes  in  the  same  digraph  with  a 
//link  from  predecessor  to  successor  and  with  no  other  links  from  predecessor  or 
//to  successor  and  with  predecessor  not  being  the  root. 

(defun  ln-same-baslc-block?  (predecessor  successor) 

(and  (non-root?  predecessor) 

(one-elt-p  (di node-predecessors  successor) ) 

(one-elt-p  (dinode-successors  predecessor) ) 

(eg  (car  (dlnode-successors  predecessor) )  successor) ) ) 


. .  + - + 

;/l  BlockGraph  | 


;A  block  graph  is  a  digraph  in  which  each  node  represents  a  block  of  nodes  in  another 
/digraph.  A  block  of  nodes  Is  a  string  of  one  or  more  nodes  in  which  every  node  except 
/the  last  has  as  its  only  successor  the  next  node  in  the  string  and  every  node  except  the 
/first  has  as  its  only  predecessor  the  previous  node  in  the  string. 
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;;; (block-nodes  block)  Is  a  list  containing  this  block's  string  of  nodes. 

;;; (block-reverse-nodes  block)  Is  the  reverse  of  (block-nodes  block). 

;;; (block-set  block),  (block-clear  block)  and  (block-val  block) 

;;;  are  temporary  variables  for  the  relaxation  algorithm. 

;;; (block-number  block)  Is  this  block's  number  used  for  the  domlnator  algorithm. 

;;; (block-domlnators  block)  is  a  bmap  of  the  block  numbers  of  the  domlnators  of  this  block, 
(defstruct  (block  (:include  dlnode)  (:prlnt-function  print-block)) 
nodes 

reverse- nodes 
set 

clear 

val 

number 

domlnators) 

///Return  a  list  representation  of  the  block's  data. 

(defun  prlntdata-block  (block) 

(nconc  (prlntdata-dinode  block) 

(list 

(cons  'nodes  (mapcar  I 'dlnode-serlal-number  (block-nodes  block))) 

(list  'set  (block-set  block)) 

(list  'clear  (block-clear  block)) 

(list  'val  (block-val  block)) 

(list  'number  (block-number  block)) 

(list  'domlnators  (block-domlnators  block))))) 

///Print  the  block. 

(defun  print -block  (block  stream  depth) 

(declare  (Ignore  depth)) 

(prinl  (cons  'block  (prlntdata-block  block))  stream)) 


;;;Get  the  block  graph  of  a  digraph.  If  an  existing  block  graph  is  available  and  the  digraph 
;;;hasn't  been  changed  since  It  was  made,  use  the  existing  block  graph;  otherwise,  create  a 
; ; ; new  one. 

(defun  get-blockgraph  (digraph) 

(attribute 

'blockgraph  (digraph-attributes  digraph) 

(let  ((blockgraph  (make-digraph))) 

(loop  for  dlnode  being  the  dlnodes  of  digraph  do  (setf  (dlnode-spare  dinode)  nil)) 

(setf  (dlnode-spare  digraph)  blockgraph! 

(loop  for  dlnode  being  the  dinodes  of  digraph  do 

(let  ( (predecessor  (car  (dl node-predecessors  dlnode)))) 

(If  (ln-same-basic-block?  predecessor  dlnode) 

(progn 

(setf  (dlnode-spare  dlnode)  (dlnode-spare  predecessor)) 

(push  dlnode  (block-reverse-nodes  (dlnode-spare  dlnode)))) 

(progn 

(setf  (dlnode-spare  dlnode) 

(make-block  ; reverse-nodes  (list  dlnode))) 

(dollst  (predecessor  (dlnode-predecessors  dlnode)) 

(if  (dlnode-spare  predecessor) 

(llnk-dinode  (dlnode-spare  predecessor)  (dlnode-spare  dlnode)))))) 
(dollst  (successor  (dinode-successors  dlnode) ) 

(If  (dlnode-spare  successor) 

(link-dlnode  (dlnode-spare  dlnode)  (dlnode-spare  successor)))))) 

,* /Calculate  the  nodes  variables. 

(loop  for  block  being  the  dlnodes  of  blockgraph  do 
(setf  (block-nodes  block) 

(reverse  (block-reverse-nodes  block)))) 
blockgraph) ) ) 


; ;  + - + 

;;|  Dataflow  Relaxation  Algorithm  I 
;;+ - - - + 

/Calculate  the  equilibrium  values  for  each  node  of  the  digraph  that  satisfy  the 
/Identity 

;  (comblnator  (list  (get-result  predecessorl)  (get-result  predecessor?) ...))- (get-val I . 

/The  algorithm  works  by  assigning  lnitlal-val  to  each  node  and  then  recalculating  the 
/values  for  each  node  using  the  above  equation  until  an  equilibrium  Is  reached. 

/An  equilibrium  Is  defined  by  the  above  equation  holding  with  I'equalp  as  a  test. 

/The  parameter  functions  are  as  follows: 

; (get-val  dlnode)  returns  the  node's  current  Input  value. 

; (set -val  dlnode  val)  sets  the  node's  Input  value  to  val. 

; (get-result  dlnode)  returns  the  node's  output  value  calculated  from  the  current  Input  value. 
;  It  should  return  the  root  value  If  called  on  the  root. 

;lnltlal-val  Is  the  Initial  Input  value  for  all  nodes. 

;root-val  Is  the  root's  result  value. 
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; ;  (combinator  extractor  Hat)  la  a  function  that  combines  the  values  returned  by  the  extractor 
;;  function  for  each  predecessor  In  the  list. 

;;frcm-end  specifies  whether  the  node's  input  comes  from  its  predecessors  (nil)  or 
;;  successors  (non-nil).  If  from-end  is  true,  the  relaxation  proceeds  backwards,  from 
;;  the  successors  to  the  predecessors. 

(defun  macro-ralax  (digraph  get-val  set-val  get -result 

they  (initial-val  bO)  (root-val  bO) 

(combinator  I 'map-b+1 
from-end) 

;;Clear  the  values. 

(loop  for  node  being  the  dinodes  of  digraph  do  (funcall  set-val  node  initial-val)) 

;;Now  iterate  through  the  digraph  until  no  more  changes  occur. 

(loop  for  changed  -  nil  do 

(loop  for  node  being  the  dinodes  of  digraph  : from-end  from-end  do 
(let  ((new-val 

(funcall  combinator 

•'(lambda  (dinode) 

(if  (root?  dinode)  root-val 

(funcall  get-result  dlnode))) 

(if  from-end  (dinode-successors  node) 

(dinode-predecessors  node) ) ) ) ) 

(unless  (equalp  (funcall  get-val  node)  new-val) 

(funcall  set-val  node  new-val) 

(setq  changed  t ) ) ) ) 
while  changed) 

;;Evaluate  get-result  on  all  digraph  nodes  in  case  it  has  any  side  effects. 

(if  from-end 

(dolist  (root-successor  (digraph-successors  digraph)) 

(funcall  get-result  root-successor))) 
digraph) 


;;Calculate  the  equilibrium  values  for  each  node  of  the  digraph  that  satisfy  the 
;; identity 

;;  (combinator  (list  (result  predecessorl)  (result  predecessor?) ...))- (get-val) , 

;;where  the  result  function  is  defined  as 

;;  (result  input) (union  set  (difference  input  clear)). 

;;The  algorithm  works  by  conceptually  assigning  lnitlal-val  to  each  node  and  then 
;; recalculating  the  values  for  each  node  using  the  above  equation  until  an  equilibrium 
;;ls  reached.  An  equilibrium  is  defined  by  the  above  equation  holding  with  I'equalp  as 
;;a  test.  Actually,  the  blocks  in  the  digraph  are  located  and  the  iteration  proceeds  only 
;;on  the  whole  blocks  and  is  later  distributed  to  the  entire  digraph.  Tor  this  reason 
;;lt  is  Important  that  union  and  difference  behave  like  ordinary  set  union  and  difference. 

s  * 

;;The  parameter  functions  are  as  follows: 

;;  (get-val  dinode)  returns  the  node's  current  input  value. 

;;  (set-val  dinode  val)  sets  the  node's  Input  value  to  val. 

;;  (get -set  dinode)  returns  the  node's  set  value. 

;;  (get-clear  dlnode)  returns  the  node's  clear  value. 

;; root-val  is  the  root's  result  value. 

;; (combinator  extractor  list)  la  a  function  that  combines  the  values  returned  by  the  extractor 
;;  function  for  each  predecessor  in  the  list. 

;; from-end  specifies  whether  the  node's  Input  comes  from  its  predecessors  (nil)  or 
;;  successors  (non-nil).  If  from-end  is  true,  the  relaxation  proceeds  backwards,  from 
;;  the  successors  to  the  predecessors. 

(defun  relax  (digraph  get-val  set-val  get-set  get -clear 
4key  (lnitlal-val  bO)  (root-val  bO) 

(union  i'logior)  (difference  f'logandc2)  (combinator  #'map-b+) 
from-end) 

(declare  (Ignore  get-val)) 

(labels 

? /Calculate  the  set  and  clear  values  in  the  block. 

( (calc-set-clear  (block) 

(let  ((ns 

(if  from-end  ;Do  the  calculation  backwards  to  minimize  get -clear  calls, 
(block-nodes  block) 

{block-reverse-nodes  block))}) 

(do  ((nodes  (cdr  ns)  (cdr  nodes)) 

(set  (funcall  get-set  (car  ns)) 

(funcall  union  set 

(funcall  difference  (funcall  get-set  (car  nodes))  clear))) 

(clear  (funcall  get-clear  (car  ns)) 

(funcall  union  clear  (funcall  get-clear  (car  nodes))))) 

( (endp  nodes) 

(setf  (block-set  block)  set) 

(setf  (block-clear  block)  clear))))) 

;;Calculate  the  information  inside  a  block  from  the  Information  on  its  boundaries, 
(micro-relax  (block) 

(do  ((nodes  (if  from-end 
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(block-reverse-nodes  block) 

(block-nodes  block)) 

(cdr  nodes)) 

(vs 1  (block-vsl  block) 

(funcall  union  (funcall  get-set  (car  nodes)) 

(funcall  difference  val  (funcall  get-clear  (car  nodes)))))) 

( (endp  nodes) ) 

(funcall  set -val  (car  nodes)  val)))) 

(let  ((blockgraph  (get -blockgraph  digraph) ) ) 

(all-dlnodes  blockgraph  #■ calc-set-clear) 

(nacro-relax 
blockgraph 
I 'block-val 

•'(lambda  (block  val)  (setf  (block-val  block)  val)) 

•* (lambda  (block) 

(funcall  union  (block-set  block) 

(funcall  difference  (block-val  block)  (block-clear  block)))) 
:lnltlal-val  lnltial-val 
: root -val  root-val 
:comblnator  comblnator 
: froo-end  from-end) 

(all-dlnodes  blockgraph  I ‘micro- re lax) ) 
digraph) ) 


•  7  •  •  —————————  — —  — — — — — — + 

;;;;|  Dominator  Algorithm  I 
;;;;+ - + 

•••Number  the  blocks  In  the  blockgraph  consecutively  starting  at  1. 

(defun  number-blocks  (blockgraph) 

(loop  for  n  from  1 

for  block  being  the  dinodes  of  blockgraph  do 
(setf  (block-number  block)  n) ) ) 

;;;Calculate  the  set  of  domlnators  for  each  block  In  the  digraph.  No  block  dominates  Itself. 
;;;The  domlnators  of  each  block  are  stored  In  the  block's  (block-domlnators)  location  as  a 
;;;bset  of  block  numbers. 

;;;Return  the  digraph's  blockgraph. 

(defun  ealc-domlnators  (digraph) 

(number-blocks  (get-blockgraph  digraph) ) 

(macro-relax 

(get-blockgraph  digraph) 

• 'block -domlnators 

•'(lambda  (block  val)  (setf  (block-domlnators  block)  val)) 

•‘(lambda  (block)  (beet  (block-number  block)  (block-domlnators  block))) 

: Initial -val  bl 
: root-val  bo 
•comblnator  •'map-b*)) 

;;;Return  true  if  blockl  dominates  block2.  Calc-domlnators  should  have  been  run  before 
•••this  routine  is  called. 

(defun  domlnatesp  (blockl  block2) 

(btest  (block-number  blockl)  (block-domlnators  block2))) 


•  • ;  + - + 

;;; I  Linearize  a  digraph  I 
;•;♦ - + 

••Order  the  elements  of  1st  according  to  the  priorities  specified  in  priorities. 
••The  returned  list  consists  of  the  elements  of  1st  ordered  by  which  ones  satisfy 
;;the  elements  of  priorities— the  elements  of  1st  that  satisfy  (first  priorities) 
••are  listed  first,  the  elements  of  1st  that  satisfy  (second  priorities)  are  listed 
••next,  and  so  on,  until  the  elements  of  1st  that  don't  satisfy  any  element  of 
,* .'priorities,  which  are  listed  last, 

(defun  priority-order  (1st  priorities  satisfied) 

(cond 

( (endp  priorities)  1st) 

( (endp  1st)  nil) 

((endp  (cdr  1st))  1st) 

((find  (car  priorities)  1st  :test  satisfied) 

(cons  (car  priorities) 

(priority-order  (remove  (car  priorities)  1st 
•test  satisfied 

•count  1)  priorities  satisfied))) 

(t  (priority-order  1st  (cdr  priorities)  satisfied)))) 

-Order  the  blocks  in  the  blockgraph  in  a  linear  fashion. 

(defun  order-blocks  (blockgraph! 
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(let  ((ordering  (new-flfo))) 

(labels 

( (order  (block  priority) 

(setf  (block-val  block  t) 

(add-fifo  ordering  block) 

(dollst  (successor  (priority-order  (dinode-succeasors  block) 

priority 

•  '  (lambda  (priority  successor) 

(or  (eq  priority  successor) 

(domlnatesp  successor  priority))))) 

(unless  (block-val  successor) 

; /Order  a  block  iff  all  of  its  predecessors  have  been  ordered,  are 
; /equal  to  that  block,  or  are  dominated  by  that  block, 

(let  ( (new-priorlty  priority) ) 

(if  (every 

<* (lambda  (predecessor) 

(or  (root?  predecessor) 

(block-val  predecessor) 

(eq  predecessor  successor) 

(progn 

(push  predecessor  new-priorlty) 

(domlnatesp  successor  predecessor)))) 

(dlnode-predecessors  successor) ) 

(order  successor  new-priorlty) ) ) ) ) ) ) 

//Use  the  (block-val)  variables  to  mark  nodes  that  have  already  been  ordered, 
(loop  for  block  being  the  dinodes  of  blockgraph  do  (setf  (block-val  block)  nil)) 
(loop  for  block  being  the  dinodes  of  blockgraph  do 
(unless  (block-val  block)  (order  block  nil))) 

(flfo-data  ordering)))) 

///Linearize  the  digraph — order  the  blocks  in  a  way  that  attempts  to  minimize 
///the  number  of  branches. 

///Return  a  list  containing  all  nodes  of  the  graph  in  the  preferred  order. 

(defun  linearize  (digraph) 

(mapcan  •• (lambda  (block)  (copy-list  (block-nodes  block))) 

(order-blocks  (calc-domlnators  digraph) ) ) ) 


Word 


CST  Compiler 

version  1.3 

written  by 
Waldemar  Horwat 

Bachelor's  thesis  under  Prof.  William  Dally 

January  21,  1988 
April  30,  1988 

Send  problems  and  comments  to 
waldemar8vx.lcs.mit.edu. 

Copyright  1988  Waldemar  Horwat 


/  ;  ;  ♦ - 4- 

; ;; |  MDP  Words  I 
;  ;  ;  + - 1 


;; ;Tags: 

(defconstant  tSYM  0) 

(defconstant  tINT  1) 

(defconstant  tBOOL  2) 

{defconstant  tADDR  3) 

(defconstant  tIP  4) 

(defconstant  tMSG  5) 

(defconstant  tCFUT  6) 

;;;Make  a  word.  If  only  one  argument  is  supplied,  set  the  tag  to  tINT. 
(defmacro  make-word  (tag  (optional  data) 

(if  data  ‘  (cons  ,tag  ,data) 

*  (cons  tINT  , tag) ) ) 

;;;Return  the  tag  of  a  word. 

(defmacro  tag  (word) 

’ (car  , word) ) 

(defun  ftag  (word)  (tag  word)) 

///Return  the  data  part  of  a  word. 

(defmacro  data  (word) 

'  (cdr  ,word) ) 

(defun  fdata  (word)  (data  word) ) 

;;;Return  true  if  the  word  is  an  integer. 

(defmacro  integer-word?  (w) 

*  (eql  (tag  , w)  tINT) ) 

/; /Return  true  if  the  word  is  an  boolean. 

(defmacro  boolean-word?  (w) 

(eql  (tag  ,  w)  tBOOL)) 

;; /Return  true  if  the  word  is  a  symbol. 

(defun  symbol-word?  (w) 

(find  w  ••.(list  tSYM  'symbol))) 

;; /Return  true  if  word  w's  tag  is  tag. 

(defun  tag-is?  (w  tag) 

(or  (eql  (tag  w)  tag) 

(and  (eql  tag  tSYM)  (eq  (tag  w)  ‘symbol)))) 


;; /Predefined  words: 

(defconstant  wNIL  (make-word  tSYM  0) ) 
(defconstant  wFALSE  (make-word  tBOOL  0)) 
(defconstant  wTRUE  (make-word  tBOOL  1)) 
(defconstant  wO  (make-word  0)) 
(defconstant  wl  (make-w  rd  1)) 
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; ; ; Short  words: 

(defconstant  short-words  (list  wNIL 

wFALSE 

wTROE 

(make-word  fx-80000000) 

(make-word  IxOOOOOOFF) 

(wake- word  *x000003FF) 

(wake-word  fxOOOOFFFF) 

(wake-word  ixOOOFFFFF) ) ) 

;; (Return  true  If  word  w  Is  a  short  constant. 

(defun  short-word?  (w) 

(or  (and  (Integer-word?  w)  (lntegerp  (data  w) )  (<-  (integer-length  (data  w) )  4)) 
(find  w  short -words  :test  •’equal))) 


;;+ - + 

;;|  Primitives.  I 


;;;The  primitives  and  bitmaps  containing  their  allowed  numbers  of  arguments  are: 
(defconstant  primitives  '((not  i(l)) 

(and  #1(1) 

(or  «1(|) 

(xor  #1(1) 

( lognot  t ( 1 ) ) 

(logand  11(1) 

(logor  11(1) 

(logxor  *1|)) 

(neg  * (1 )) 

(♦  »1(H 

(-  «<2|) 

(*  *1(1) 

(//  • (2 1 ) 

(mod  •  ( 2 ) ) 

(ash  i{2|) 

(max  *1(0)) 

(min  11(01) 

(<  *(2)) 

«-  «<2|) 

(>  »{2)) 

(>-  »(21) 

(-  ♦12)) 

(<>  *  ( 2 ) ) 

(eq  f ( 2 ) ) 

(neq  *(2)))) 
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;;|  Variable  and  temporary  slot*  and  locations.  { 


;+• 


Each  target  and 
(self) 

(var  .  n) 

(arg  .  n) 

(ivar  .  n) 
(const  .  w) 


argument  slot  is  a  pair  in  one  of  the  following  formats: 
self 

variable  or  temporary  #n  (n  nonnegative,  consecutive) 
argument  fn 
instance  variable  In 
constant  word  w 


///Make  a  slot  with  the  type  and  number. 

(defmacro  make-slot  (type  {optional  number) 

*(cons  ,type  , number) ) 

;;;Hake  a  constant  slot  with  the  given  tag  and  data. 

;;;If  only  one  argument  is  supplied,  set  the  tag  to  tINT. 
(defmacro  make-const  (tag  {optional  data) 

(if  data  '(make-slot  'const  (make-word  , tag  ,data)) 
'(make-slot  'const  (make-word  ,tag)))) 

;? /Return  the  slot's  number. 

(defmacro  slot-num  (slot) 

' (cdr  , slot) ) 

;; /Return  the  slot's  type. 

(defmacro  slottype  (slot) 

' (car  ,slot) ) 

///Return  true  if  the  slot's  type  matches  type. 

(defmacro  slot-is  (type  slot) 

' (eq  (car  ,slot)  ,type)) 

(defmacro  const?  (slot) 

*  (eq  (car  ,slot)  'const)) 

(defmacro  self?  (slot) 

*  (eq  (car  ,slot)  'self)) 

(defmacro  var?  (slot) 

‘ (eq  (car  ,slot)  'var)) 

(defmacro  arg?  (slot) 

(eq  (car  ,slot)  'arg)) 

( defmacro  1 var?  (slot) 

(eq  (car  ,slot)  'ivar)) 


(defun  integer-const ?  (slot) 

(and  (const?  slot)  (integer-word?  (slot-num  slot)))) 

///If  the  slot  is  a  variable,  set  its  bit  in  the  bmap;  otherwise,  just  return  the  bmap. 
(defun  var?bset  (slot  {optional  (bmap  b0)) 

(if  (var?  slot)  (bset  (slot-num  slot)  bmap) 
bmap) ) 
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; ; ; ; I  Statement  | 

////♦ - + 

(defstruct  (stmt  (: include  d Inode) 
operation 
target 
■ethod 


(•.print -function  print-atet) ) 


args 

live-in  /Snap  of  variable!  live  at  beginning  of  atatement. 

live-out  /Bmap  of  variables  live  at  end  of  statement, 

waiting-in  /Bmap  of  variables  waiting  at  beginning  of  statement, 

forced-ln  ;Bmap  of  variables  guaranteed  to  be  forced  at  beginning  of 

dflow-in  /Dataflow  record  at  the  beginning  of  statement, 

n-unused-regs  /Number  of  registers  available  for  allocation, 
reserved-regs  /Bsiap  of  registers  reserved  by  statement, 
used-regs  /(heap  of  registers  used  for  variables, 
frame)  /Frame  of  register  assignments  at  the  end  of  statement. 


statement . 


///Access  the  first  argument.  This  can  be  used  in  a  setf. 
(defmacro  stmt-arg  (stmt) 

(car  (stmt-arga  .stmt))) 


///Access  the  second  argument.  This  can  be  used  in  a  setf. 
(defmacro  stmt~arg2  (stmt) 

' (cadr  (stmt-arga  .staft))) 


///Return  a  list  representation  of  the  statement's  data. 

(defun  prlntdata-stmt  (stmt) 

(nconc  (prlntdata-dlnode  stmt) 

(list 

(list  ‘stmt  (stmt -operation  stmt) 

(stmt -target  stmt) 

(stmt -method  stmt) 

(stmt-args  stmt)) 

(list  'live  (stmt-live-in  stmt) 

(stmt-live-out  stmt)) 

(list  ‘waltlng-ln  (stmt-wait lng- In  stmt)  (stmt-forced-ln  stmt)) 
(list  ‘dflow-in  (stmt-dflow-ln  stmt)) 

(list  'regs  (stmt -n-unused-regs  stmt) 

(stmt -reserved- reqs  stmt I 
(stmt -used-regs  stmt))))) 

///Print  the  stateaMnt. 

(defun  print-stmt  (stmt  stream  depth) 

(declare  (Ignore  depth) ) 

(prlnl  (cons  'stmt  (prlntdata-stmt  stmt))  stream)) 


///The  possible  internal  statements  are: 


;  {enter 

nil 

nil 

nil) 

/Entry  code. 

;  (csend 

target 

nil 

slot-list) 

/Send  message  without  forcing  target. 

;  (rsend 

nil 

nil 

slot-list) 

/Send  message  and  forward  reply  to  caller. 

; (primitive 

target 

primitive 

slot-list) 

/Execute  the  primitive. 

;  (move 

dest-slot 

nil 

source-slot) 

/Move  source-slot  to  dest-slot. 

/  (touch 

nil 

nil 

source-slot) 

/Make  sure  that  source-slot  is  forced. 

;  (new 

slot 

class-name 

nil) 

/Make  a  new  object  of  the  class  and  store  It 

;  (condition 

nil 

condition 

slot) 

/Branch  If  condition  on  slot  is  true. 

;  (reply 

nil 

nil 

source-slot) 

/Reply  with  the  value  in  source-slot. 

; (exit 

nil 

nil 

nil) 

; Exit  code. 

///Return  true  if  the  two  statements  are  equal. 

(defun  equal-stmt  (stmtl  stmt2) 

(or  (eq  stmtl  stmt2) 

(and  (equal  (stmt -operation  stmtl)  (stmt-operation  stmt2)) 
(equal  (stmt -target  stmtl)  (stmt -target  stmt2)) 

(equal  (stmt -method  stmtl)  (stmt -method  stmt2)) 

(equal  (stmt-args  stmtl)  (stmt-args  stmt2))))) 


///Return  true  if  the  two  statements  are  are  nearly  equal,  allowed  only  to  differ 
///the  hinds  (but  nut  number)  rr  arguments. 

(defun  simi la r- in-stmt  (stmtl  stmt2) 

(or  (equal-stmt  stmtl  stst2) 

(and  (equal  (stmt -operation  stmtl)  (stmt -operation  stmt2)) 

(not  (eq  (stmt -operation  stmtl)  ‘move)) 

(equal  (stmt -target  stmtl)  (stmt -target  stmt2)) 

(equal  (stmt -method  stmtl)  (stmt -method  stmt2)) 

(-  (length  (stmt-args  stmtl))  (length  (stmt-args  stmt2)))))) 


in 
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Stmt 


///Return  true  it  the  two  stateeients  ere  ere  neerly  equel,  allowed  only  to  differ  In 
///the  target. 

,  (defun  slallar-out-stmt  (statl  stmt2) 

(or  (equal-stat  statl  stat2) 

(and  (equal  (atat -operation  atotl)  (stmt -operation  stmt2)) 

(not  (eq  (stat-operation  atatl)  'novel ) 

(equal  (stat-aethod  atatl)  (atat -method  stat2)) 

1  (equal  (stat-args  atatl)  (atat-arga  atat2)>))) 


///Return  true  If  the  stateaent  operation  la  a  kind  of  a  send, 
(defun  send-operatlon?  (operation) 

(find  operation  • (csend  rsend) ) ) 


;;;Return  the  opposite  condition  to  the  given  condition. 

(defun  opposite-condition  (condition) 

(cadr  (assoc  condition  '(<bt  Of)  (bl  bt)  (bnll  bnnll)  (bnnil  bnll)  (bz  bnz)  (bnz  bz))))) 

;;;Return  the  opposite  comparison. 

(defun  opposite-comparison  (comparison) 

(cadr  (assoc  comparison  • ( (-  <>)  (<>  -)  (eq  neq)  (neq  eq) ) ) ) ) 


;; /Return  a  hasp  of  all  variables  defined  In  the  statement. 

(defun  stat-def  (stmt) 

(var?bset  (stmt-target  stmt))) 

///Return  a  hmap  of  all  variables  used  In  the  statement. 

(defun  stat-use  (atat) 

(aap-b+  I'varfbaet  (stat-args  stmt))) 

(defconstant  forcing-stmts  '(primitive  move  new)) 

///Return  a  tamap  of  all  variables  forced  by  the  statement. 

(defun  stmt-force  (stmt) 

(If  (find  (stmt -operation  stmt)  forcing-stmts) 

(var?bset  (stmt-target  stmt)  (stmt-use  stmt)) 

(stat-use  stmt))) 

///Return  a  bmap  of  all  variables  that  are  waiting  at  the  end  of  the  statement, 
{defun  stmt-waltlng-out  (etmt) 

(b-  (b+  (stmt-wait lng-ln  stmt) 

(atmt-def  stmt)) 

(stmt-force  stmt))) 


///Return  a  bmap  of  all  variables  that  are  guaranteed  to  be  forced  by  the  statement, 
///regardless  of  optimizations  that  are  later  performed. 

(defun  stmt-must-force  (stmt) 

(case  (stmt-operatlon  stmt) 

(exit  bl) 

( (csend  rsend  touch) 

(map-b+  #'  (lambda  (slot)  (var?b*et  slot))  (stmt-args  stmt))) 

(reply 

(If  (eq  (stmt-operatlon  (first  (stmt-successors  stmt)))  'exit) 

(varfbset  (stat-arg  stmt) ) 
bO)) 

(t  bO))) 


///Return  a  hmap  of  all  variables  that  are  guaranteed  to  be  forced  at  the  end  of  the  statement, 
///regardless  of  optimizations  that  are  later  performed. 

(defun  stmt-forced-out  (stmt) 

(let  ((forced- In  (b+  (stmt-forced-ln  stmt)  (stmt -must-force  stmt)))) 

(If  (and  (var?  (stmt -target  stmt)) 

(not  (and  (find  (stmt-operatlon  stmt)  forcing-stmts) 

(every  •' (lambda  (slot) 

(or  (not  (var?  slot)) 

(btest  (slot-num  slot)  forced-in))) 

(stmt-args  stmt))))) 

(bclr  (slot-num  (stmt-target  stmt))  forced-ln) 
forced-ln) ) ) 


///+ - + 

/// I  stmtgraph  I 
/  Z  z  + - * 

//A  stmtgraph  Is  a  digraph  of  stmts  together  with  some  common  Information, 
(defstruct  (stmtgraph  (: Include  digraph) 

(/print-function  prlnt-stmtgraph) ) 
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nvars)  /The  number  of  local  variables  and  temporaries. 


;? /Print  the  stmt graph. 

(defun  prlnt-stmtgraph  (stmtgraph  stream  depth) 

(declare  (ignore  depth) ) 

(write-string  *#<Stotgraph  “  stream) 

(print-digraph-data  stmtgraph  stream) 

(format  stream  “  nvars  -S>"  (stmtgraph-nvars  stmtgraph))) 


///Return  a  new  variable  and  update  the  variable  count  in  the  stmtgraph. 
(defun  gen-var  (stmtgraph) 

(progl 

(make-slot  'var  (stmtgraph-nvars  stmtgraph) ) 

(incf  (stmtgraph-nvars  stmtgraph)))) 
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I  Variable  and  temporary  locations.  | 


;Each  location  can  be  ary  of  the  items  below: 

;  (sconst  .  w)  short  constant  word  w 
;  (1 const  .  w)  long  constant  word  w 
;  (reg  .  n)  register  In 

?  (areg  .  n)  address  register  in 

;  (sreg  .  r)  special  register  r 

;  (vloc  .  n)  variable  or  temporary  located  at  offset  n 
? (aloe  .  n)  argument  located  at  offset  n 

;  (iloc  .  n)  instance  variable  located  at  offset  n 

;  (rel)  Offset  for  this  branch  (or  the  next  branch  if  used  in  a  DC  statement) 


;;;Make  a  location  with  the  type  and  number. 

(defmacro  make-loc  (type  *optional  value) 

(cons  , type  , value)) 

r;;Make  a  short  constant  slot  with  the  given  tag  and  data. 
r;;If  only  one  argument  is  supplied,  set  the  tag  to  tINT. 
(defmacro  make-sconst  (tag  (optional  data) 

(if  data  (make-loc  'sconst  (make-word  ,  tag  , data)) 
(make-loc  'sconst  (make-word  ,tag)))) 

r;;Make  a  long  constant  slot  with  the  given  tag  and  data. 
:;?If  only  one  argument  is  supplied,  set  the  tag  to  tINT. 
(defmacro  make-lconst  (tag  (optional  data) 

(if  data  '  (make-loc  *1  const  (make-word  ,tag  , data)) 
(make-loc  ' lconst  (make-word  ,tag)))) 

r;;Return  the  location's  number. 

(defmacro  loc-num  (loc) 

*  (edr  , loc) ) 

/Return  the  location's  type. 

(defmacro  loctype  (loc) 

(car  , loc) ) 

?;;Return  true  if  the  location's  type  matches  type, 
(defmacro  loc-is  (type  loc) 

'  (eq  (car  , loc)  ,type) ) 

(defmacro  sconst?  (loc) 

‘ (eq  (car  ,loc)  'sconst)) 

(defmacro  lconst?  (loc) 

(eq  (car  ,loc)  'lconst)) 

(defmacro  relative?  (loc) 

(eq  (car  , loc)  'rel)) 

(defmacro  reg?  (loc) 

’ (eq  (car  ,loc)  'reg)) 

(defmacro  areg?  (loc) 

*  (eq  (car  ,loc)  'areg)) 

(defmacro  sreg?  (loc) 
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'  (eq  (car  , loc)  ‘sr*q)) 
(defmacro  vloc?  (loc) 

'  (eq  (car  ,  loc)  *vlo c) ) 
(defmacro  aloe?  (loc) 

' (eq  (car  , loc)  'aloe)) 
(defmacro  Hoc?  (loc) 

• (eq  (car  , loc)  'lloc) ) 

; (defmacro  reg-num  (loc) 

;  ' (edr  , loc) ) 

(defun  reg-num  (loc) 
(assert  (req?  loc) ) 

(edr  loc) ) 


(defconstant  reqO  (make-loc  ‘req  0)) 

(defconstant  reql  (make-loc  *req  1)) 

(defconstant  req2  (make-loc  ‘req  2)) 

(defconstant  req3  (make-loc  ‘req  3)) 

(defconstant  context-a-req  (make-loc  ‘areq  1)) 

(defconstant  lnstance-a-req  (make-loc  ‘areq  2)) 

(defconstant  arqument-a-req  (make-loc  ‘areq  3)) 

(defconstant  contextID  (make-loc  ‘vloc  1)) 

(defconstant  self loc  (make-loc  ‘aloe  2)) 

(defconstant  msq-overhead  (If  ‘reply-node*  5  4)) 

;Slze  of  incomlnq  messaqe  minus  the  number  of  arguments, 

.■counting  the  receiver  as  an  argument. 

(defconstant  max-context-sire  1C)  ;Maxlmum  addressable  context  sire, 
(defconstant  flrst-context-slot-num  S)  ,-Flrst  usable  context  slot  number, 
(defconstant  flrst-lnatanee-slot-num  2) 

(defconstant  flrst-arq-slot-num  3) 


;;;Return  true  if  the  opcode  Is  a  branch. 

(defun  branch?  (op) 

(find  op  ‘ (br  bt  bf  bnll  bnnll  bz  bnz))) 

; ; (Return  true  If  the  opcode  la  a  send. 

(defun  send-op?  (op) 

(find  op  ‘(send  sende  send2  send2e) ) ) 

;;;Return  true  If  the  opcode  Is  a  stack  operation. 

(defun  stack-op?  (op) 

(or  (eq  op  ‘push)  (eq  op  ’pop))) 

.-.-.•Return  true  If  the  opcode  Is  an  associative  cache  operation, 
(defun  assoc-op?  (op) 

(find  op  1 (xlate  enter  probe  purge))) 


;;;;l  Instruction  I 
;  • ;  ;  + - - - + 

(defstruct  (Inst  (:include  dlnode)  (:prlnt-functlon  prlnt-inst) ) 


label 

op 

srcl 

src2 

dst 

reads 

writes 

live 

vllve 

pc 

next 

prev) 


?The  label  number  for  this  Instruction. 


;Map  of  registers  whose  values  are  used  by  this  instruction. 

;Map  of  registers  written  or  trashed  by  this  Instruction. 

?Map  of  registers  live  at  the  end  of  this  instruction. 

;Map  of  vlocs  live  at  the  end  of  this  instruction. 

;The  program  counter  in  half-words. 

;The  next  Instruction  In  the  output  code  or  NIL  if  there  is  none. 

;The  previous  Instruction  In  the  output  code  or  NIL  if  there  is  none. 


;/;  Return  a  list  representat ion  of  the  instruction • s  data, 
(defun  printdata-inst  (Inst) 

(nconc  (print data -dlnode  Inst) 

(list 

(list  'label  (inst-label  inst)> 

(list  'op  (Inst -op  inst) 

(inst-srcl  Inst) 

(inst-src2  inst) 

(Inst -dst  inst)) 

(list  'reads  (lnst-reads  Inst) 
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'writ**  (inst -write*  inst)) 

(lice  ‘llv«  (lnst-llvs  inst)) 

(li*t  'vllve  (Inst -vllve  Inst)) 

(list  'pc  (lnst-pc  Inst)) 

(list  *pre»  (If  (lnst-prev  Inst)  (inst-serlal-number  (lnst-prev  Inst))) 

•next  (If  (lnst-next  Inst)  (lnst-serlsl-number  (lnst-next  Inst))))))) 


;;;  Print  the  Instruction 

(defun  prlnt-lnst  (Inst  stream  depth) 

(declare  (Ignore  depth)) 

(prlnl  (cons  'Inst  (prlntdata-lnst  Inst))  stream)) 


;;;Return  a  taeup  of  register  usage  by  loc. 

(defun  regbeup  (loc) 

(If  (reg?  loc) 

(beet  (loc-nua  loc)) 
bO) ) 

;;;Creat e  a  nee  Instruction  with  defaults  for  the  reads  and  writes  fields, 
(defun  new-lnst  ((key  op  srcl  src2  dst  reads  writes  live) 

(make-lnst 
top  op 
tsrcl  srcl 
:src2  src2 
tdst  dst 

treads  (or  reads  (b+  (regbmap  srcl)  (regbmap  src2))) 
twrltes  (or  writes  (regbmap  dst)) 
t live  live)) 


(defmacro  lnst-addr  (Inst) 
‘(floor  (lnst-pc  ,lnst)  2)) 


;;;Llnk  the  from  Instruction  to  the  to  Instruction, 
(defun  llnk-lnst  (from  to) 

(setf  (lnst-next  from)  to) 

(setf  (lnst-prev  to)  from)) 


(defun  branch-dest  (Inst) 

(car  (last  (lnst-successors  Inst)))) 


as* - * 

as  I  Module  I 
. . ;  + - + 

;;A  module  Is  a  collection  of  lnsts  linked  as  both  a  digraph  and  a  static  sequence  of 
; (Instructions. 

(defstruct  (module  (:lnclude  Inst  (serial-number  nil)) 

(rprlnt -function  print-module)) 
digraph)  ;The  digraph  of  instructions. 


Inst 


;;;Prlnt  the  module. 

(defun  print-module  (module  stream  depth) 

(declare  (Ignore  depth)) 

(format  stream  "#<Module  -S  ■  (module-digraph  module)) 

(print -range-1 1st  # * inst-serial-number  (module-inst-list  module)  stream) 
(write-char  l\>  stream)) 


;?;Return  true  if  inst  is  actually  a  module  header, 
(defmacro  module?  (inst) 

*  (root?  , inst) ) 

(defmacro  non-module?  (inst) 

*  (non- root?  , Inst)) 


;;;Mark  the  module  as  altered. 

(defun  altered-module  (module) 

(altered-dlgraph  (module -digraph  module))) 


;;;Call  function  f  in  order  on  each  instruction  in  the  module. 
;?;If  from-end  is  non-nil,  call  function  f  in  the  reverse  order, 
(defun  all-insts  (module  f  tkey  from-end) 

(if  from-end 

(do  ((inst  (module-prey  module)  (lnst-prev  inst))) 
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( (module?  Inst) ) 

(funcall  f  Inst)) 

(do  ((Inst  (module-next  module)  (lnst-next  Inst))) 
((module?  Inst)) 

(funcall  f  Inst)))) 


;;;Retum  an  ordered  list  of  the  module's  Instructions, 
(defun  module-lnst-llst  (module) 

(do  ((Inst  (module-prev  module)  (lnst-prev  Inst)) 

(1  nil  (cons  Inst  1))) 

((module?  Inst)  1))) 


I 

; ; ; Return  the  Inst  in  the  module  with  serial  number  nf  if  any. 
;;;Thls  function  is  intended  for  debugging. 

(defun  nth-inst  (module  n) 

(do  ((inst  (module-next  module)  (lnst-next  Inst))) 

((module?  inst)) 

(if  (eql  (lnst-serlal-number  inst)  n)  (return  inst)))) 


;;;Delete  the  instruction. 

(defun  delete-inst  (inst) 

(llnk-lnst  (lnst-prev  inst)  (lnst-next  inst))) 

;;;Insert  new-lnat  between  prev-inst  and  next-inst,  breaking  the  link  between 
;;;prev-inst  and  next-inst. 

(defun  insert-lnst  (new-lnst  prev-inst  next-inst) 

(link-inst  prev-inst  new-lnst) 

(link-lnst  new-lnst  next-inst)) 


;;;Delete  the  instruction  from  the  module,  updating  both  the  static  order  and  the  digraph, 
(defun  delete-module  (module  inst) 

(delete-d inode  inst) 

(delete-inst  Inst) 

(altered-module  module)) 

;;; Insert  new-lnst  into  the  module  between  pred-inst  and  succ-inst,  breaking  the  digraph 
;;;llnk  between  pred-inst  and  succ-inst,  Pred-inst  and  succ-inst  do  not  have  to  be 
;;;next  to  each  other  in  the  static  order,  but  there  must  be  a  digraph  link  from 
;;;pred-inst  to  succ-inst. 

(defun  insert -module  (module  new-inst  pred-inst  succ-inst) 

{ insert -dlneic*  ^ew-inst  pred-ln«:*  succ-inst) 

(insert-inst  new-inst  pred-inst  (lnst-next  pred-inst) ) 

(altered-module  module) ) 


?;;Insert  new-inst  into  the  module  in  front  of  inst,  linking  all  of  inst*s  dynamic 
;;; predecessors  to  new-inst  Instead. 

(defun  Insert -be fore-module  (module  new-inst  inst) 

(insert -before-dinode  new-lnst  inst) 

(insert-lnst  new-lnst  (inst-prev  inst)  lr.st) 

(altered-module  module) ) 


;;;Swap  pred-inst  and  succ-inst,  which  must  be  consecutive  instructions  in  the 
; ; ; module. 

(defun  swap-module  (module  pred-inst  succ-inst) 

(delete-module  module  succ-inst) 

(insert -before-module  module  succ-inst  pred-inst)) 


i 
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. ; ;  + - ♦ 

; ; ; I  Preprocess  the  lcode  I 
•  ;  ;  + - + 

;;Preprocess  the  lcode  to  make  the  following  changes: 

;;  Add  an  enter  statement  to  the  beginning  of  the  lcode  If  one  Isn't  already  present. 
;;  Merge  all  returns  and  return-xs  Into  one  return  at  the  end. 

;,*  Merge  all  exit  stateawnts  Into  one  exit  at  the  end. 

(defun  preprocess- lcode  (lcode) 

(let  ( (now- lcode  (new-flfo))) 

(unless  (aq  (caar  lcode)  'enter) 

(add-flfo  new-lcoda  '(enter))) 

(dollst  (lstnt  lcode) 

(case  (car  lstmt) 

((return  return-x) 

(assert  (-  (length  lstmt)  2)) 

(add-flfo  new-lcode  (list*  ’move  '(temp  return-value)  (cdr  lstmt))) 

(add-flfo  new-lcode  '(jump  return))) 

(exit 

(assert  (-  (length  lstmt)  1)) 

(add-flfo  new-lcode  '(jump  exit))) 

(t  (add-flfo  new-lcode  lstmt)))) 

(add-flfo  new-lcode  '(jump  exit)) 

(add-flfo  new-lcode  '(label  return)) 

(add-flfo  new-lcode  '(reply  (temp  return-value))) 

(add-flfo  new-lcode  '(label  exit)) 

(add-flfo  new-lcode  ‘(exit)) 

(flfo-data  new-lcode))) 


. .  •  ————————————— 

;;;|  Convert  the  lcode  Into  a  stmtgraph  I 
SSI* - ♦ 

;;Convert  the  Input  lcode  Into  a  stmtgraph  and  return  the  resulting  stmtgraph. 

(defun  dlgraphlze-lcode  (lcode) 

(labels 

;;Search  the  labeltable  for  the  label.  Return  the  stmt  corresponding  to  the  label 
;;or  nil  If  there  Is  none. 

((find-label  (label  labeltable) 

(cdr  (assoc  label  labeltable))) 

;;Same  as  find-label  except  that  give  an  error  message  instead  of  returning  nil. 
(eflnd-label  (label  labeltable) 

(cond  ((find-label  label  labeltable)) 

(t  (error  "Undefined  label  -S"  label)))) 

;;Add  the  stmt  to  the  labeltable  under  the  names  In  labels  and  return  the  new 
.‘.'labeltable. 

(add-labels  (labeltable  labels  stmt) 

(If  (endp  labels) 
labeltable 

(let  ((label  (car  labels))) 

(if  (find-label  label  labeltable) 
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(error  "Duplicate  label  -S“  label)) 

(add-labels  (aeons  label  stmt  labeltable)  (rdr  labels)  stmt)))) 

/Create  a  stmtrec  from  the  source  lcode  statement. 

;A  stmtrec  Is  a  pair  whose  edr  Is  a  stmt  and  car  Is  a  list  of  successor  statement 
/labels.  Each  label  Is  either  a  real  label  or  'next  to  Indicate  that  the  next 
/statement  In  the  code  sequence  is  a  successor. 

(create- stmtrec  (stmt) 

(ecaae  (first  stmt) 

(enter 

(assert  (-  (length  stmt)  1)) 

(cons  *  (next) 

(make-stmt 

: operation  'enter))) 

((csend  primitive) 

(cons  ' (next) 

(let  ((method  (third  stmt))) 

(if  (and  (consp  method) 

(eq  (car  method)  'method) 

(let*  ( (met hod -name  (cadr  method)) 

(primitive-data  (assoc  method-name  primitives))) 
(when  primitive-data 

(if  (not  (btest  (length  (edddr  stmt)) 

(cadr  primitive-data))) 

(error  "Bad  number  of  arguments  to  primitive  -S:  -S” 
met hod- name 
(edddr  stmt))) 

t))) 

(make-stmt 

: operation  'primitive 
: target  (second  stmt) 

:method  (cadr  method) 

:args  (edddr  stmt)) 

(if  (eq  (first  stmt)  'primitive) 

(error  “Bad  primitive  -S"  method) 

(progn 

(assert  (>-  (length  stmt)  4)) 

(make-stmt 

/operation  (first  stmt) 

:target  (second  stmt) 

:args  (eddr  stmt) ))))))) 

(touch 

(assert  (-  (length  stmt)  2)) 

(cons  '  (next) 

(make-stmt 
:operation  'touch 
:args  (edr  stmt)))) 

(move 

(assert  (-  (length  stmt)  3)) 

(cons  •  (next) 

(if  (equal  (second  stmt)  (third  stmt)) 

(make-stmt)  /Eliminate  null  moves. 

(make-stmt 
: operation  'move 
: target  (second  stmt) 

:args  (eddr  stmt))))) 

(new 

(assert  (-  (length  stmt)  3)) 

(cons  '  (next) 

(make-stmt 
:operation  'new 
: target  (second  stmt) 

:method  (third  stmt)))) 

(false jump 

(assert  (-  (length  stmt)  3)) 

(cons  (list  'next  (caddr  stmt)) 

(make-stmt 

:operatlon  'condition 
:method  'bf 

:args  (list  (second  stmt))))) 

(jump 

(assert  (•  (length  stmt)  2)) 

(cons  (edr  stmt) 

(make-stmt)))  /Create  a  null  statement 
((reply  reply-x) 

(assert  (-  (length  stmt)  2)) 

(cons  '  (next) 

(make-stmt 
/operation  'reply 
:args  (edr  stmt) ) ) ) 

(exit 
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(assart  (•  (length  stmt)  1)) 

(cons  nil 

(make-stmt 

: operat Ion  *  exit ) ) ) ) ) 

; ;Stmtrec-£lfo  Is  a  flfo  of  statements. 

;; Return  a  list  of  stmtrecs  and  the  label  table, 
(create-stmtrecs  (stmtrec-f lfo  labaltable  labels  lcode) 
(If  (null  lcode) 

(values  (flfo-data  statrec-f lfo) 

(add-labels  labeltable  labels  nil)) 

(let  ((statement  (car  lcode))) 

(If  (eq  (car  statement)  'label) 

(progn 

(assert  (-  (length  statement)  2)) 
(create-stmtrecs 
stmtrec-flfo 
labeltable 

(cons  (cadr  statement)  labels) 

(cdr  lcode))) 

(let  ( (stmtrec  (create-stmtrec  statement))) 
(create-st mtrecs 
(add-flfo  stmtrec-flfo  stmtrec) 

(add-labels  labeltable  labels  (cdr  stmtrec)) 
nil 

(cdr  lcode)))))))) 
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(multlple-value-blnd  (stmtrecs  labeltable) 

(create-stmtrecs  (new-fifo)  nil  1 (start)  lcode) 

(mapl 

I1  (lambda  (stmtrec- list) 

(let  ((stmtrec  (car  stmtrec-llst) ) ) 

(dolist  (successor  (car  stmtrec)) 

(if  (eq  successor  ’next) 

(if  (cdr  stmtrec-list) 

( link -d inode  (cdr  stmtrec)  (cdadr  stmtrec-list)) 

(error  "Execution  can  fall  off  the  end  of  the  procedure")) 
(link-dinode  (cdr  stmtrec)  (efind-label  successor  labeltable)))))) 

stmtrecs) 

(delete-dinode-1 f 

(new-digraph  (list  (efind-label  *  start  labeltable))  (make-stmtgraph) ) 

#•  (lambda  (stmt)  (null  (stirt-operat ion  stmt))))))) 


;;;;|  Canonallre  names  in  the  stmtgraph.  | 

•  •  •  •  +— ————————— — — ————————— + 

;;;An  index-list  is  a  list  of  item  numbered  consecutively  starting  at  0. 

;; /New- index- list  creates  a  new  index-list  with  no  objects. 

(defun  new- index-list  ()  (list  nil)) 

///Add  item  to  the  index-list.  If  it  was  already  present  (compared  by  equal) 
?;?in  the  index-list,  return  its  old  number.  Otherwise,  assign  it  the  next 
;;;number,  add  it  to  the  index-list,  and  return  the  new  number. 

///The  count  parameter  is  for  internal  use  only. 

(defun  add-index-list  (index-list  item  toptlonal  (count  0)) 

(cond  ( (endp  (cdr  index-list)) 

(setf  (cdr  index-list)  (list  item)) 
count) 

((equal  Item  (cadr  index-list)} 
count ) 

(t  (add-lndex-list  (cdr  index-list)  item  (1+  count))))) 

;; /Return  the  number  of  items  in  the  index-list.  The  next  item  will  get  this 
?; /number  if  it  is  not  found  in  the  index- list. 

(defun  index-1 ist-num  (index-list) 

(length  (cdr  index-list))) 

////Canonall  *  the  names  of  the  slots  in  the  stmtgraph. 

////Return  the  stmtgraph. 

(defun  varcanon-stmtgraph  (stmtgraph) 

(let  ( (vars  (new-index-i 1st) ) ) 

(labels 

( (extract -number  (slot) 

(let  ((slot-tail  (cdr  slot))) 

(cond  ((integerp  slot-tail)  slot-tail) 

((and  (null  (cdr  slot-tall))  (Integerp  (car  slot-tail))) 

(car  slot-tall)) 

(t  (error  "Bad  slot  specification:  ~S"  slot))})) 
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(extract -symbol  (slot) 

(let  ((slot -tail  (cdr  slot))) 

(cond  ((symbolp  slot-tall)  slot -tall) 

((and  (null  (cdr  slot -tall))  (symbolp  (car  slot-tall))) 

(car  slot-tall)) 

(t  (error  “Bad  slot  specification:  -s*  slot))))) 

(varcanon  (slot) 

(cond 

((consp  slot) 

(case  (car  slot) 

( (temp  var) 

(make-slot  'var  (add-lndex-list  vars  slot))) 

(arg 

(make-slot  'arg  (extract -number  slot))) 

(lvar 

(make-slot  'lvar  (extract-number  slot))) 

(const 

(cond 

((null  (cdr  slot)) 

(error  "Bad  slot  specification:  -S“  slot)) 

((and  (null  (cadr  slot))  (null  (cddr  slot))) 

'*. (make-slot  'const  wNIL) ) 

((and  (symbolp  (cadr  slot))  (null  (cddr  slot))) 

(case  (cadr  slot) 

((false)  (make-slot  'const  wFALSE) ) 

((t  true)  (make-slot  'const  wTRUE) ) 

(t  (make-const  'symbol  (cadr  slot))))) 

((and  (numberp  (cadr  slot))  (null  (cddr  slot))) 

(make-const  (cadr  slot))) 

((and  (numberp  (cadr  slot))  (numberp  (caddr  slot))  (null  (cdddr  slot))) 
(make-const  (cadr  slot)  (caddr  slot))) 

(t  (error  "Bad  slot  specification:  -S*  slot)))) 

(self  (make-slot  'se If)) 

(method  (make-const  'method  (extract-symbol  slot))) 

(t  (error  "Bad  slot  specification:  ~S“  slot)))) 

((null  slot)  nil) 

((integerp  slot)  (make-const  slot)) 

((eq  slot  ‘self)  (make-slot  'self)) 

(t  (error  “Bad  slot  specification:  slot))!)) 

(loop  for  stmt  being  the  dinodes  of  stmtgraph  do 

(setf  (stmt -target  stmt)  (varcanon  (stmt-target  stmt))) 

(setf  (stmt-args  stmt)  (mapcar  f ‘varcanon  (stmt-args  stmt)))) 

(setf  (stmtgraph-nvars  stmtgraph)  (lndex-llst-num  vars)) 
stmtgraph) ) ) 


:;;l  Input  a  stmtgraph.  I 


;;;Convert  the  icode  into  a  stmtgraph  and  return  that  stmtgraph. 

(defun  lnput-icode  (icode) 

(varcanon-stmtgraph  (purge-unreachables-dlgraph  (dlgraphize-icode  (preprocess-icode  icode))))) 


;|  Output  the  stmtgraph  in  a  readable  format.  I 


(defun  non-nil-list  (arg) 

(if  arg  (list  arg) ) ) 

;;;Output  a  statement. 

(defun  output-stmt  (stmt) 

(let  ((output  (nconc  (list  (stmt-operation  stmt)) 

(non-nll-llst  (stmt-target  stmt)) 

(non-nil-list  (stmt-method  stmt) ) 

(stmt-args  stmt)))) 

(if  (eq  (stmt -operation  stmt)  'condition) 

(append  output  (list  (stmt-serlal-number  (second  (stmt-successors  stmt))))) 
output) ) ) 

;;;Output  a  stmtgraph. 

(defun  output-stmtgraph  (stmtgraph) 

(let  ( (prev-stmt  nil)) 

(mapcon 

•  '(lambda  (stmts) 

(let  ((stmt  (car  stmts)) I 
(progl 
(nconc 
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(unless  (and  (one-elt-p  (stmt-predecessors  stmt) ) 

(or  (null  prev-stmt) 

(eq  prev-stmt  (car  (stmt-predecessors  stmt))))) 

(list  (list  'label  (stmt-serial-number  stmt)))) 

(list  (output-stmt  stmt)) 

(if  (and  (stmt-successors  stmt) 

(not  (eq  (cadr  stmts)  (first  (stmt-successors  stmt))))) 

(list  (list  'jump  (stmt-serial-number  (first  (stmt-successors  stmt))))))) 
(setq  prev-stmt  stmt) } ) ) 

{di graph- df s  stmt graph) ) ) ) 


;?;(  Calculate  dataflow  information.  \ 


;; /Calculate  the  live  data  for  each  statement  in  the  stmtgraph. 

(defun  calc-live  (stmtgraph) 

(attribute 

'live  (stmt graph-attributes  stmtgraph) 

(macro-relax  stmtgraph 

• • stmt -1 ive-out 

•'(lambda  (stmt  new-live-out)  (setf  (stmt-live-out  stmt)  new-live-out)) 
#*  (lambda  (stmt) 

(setf  (stmt-live-in  stmt)  (b+  (stmt-use  stmt) 

(b-  (stmt-live-out  stmt) 

(stmt-def  stmt))))) 

:from-end  t) ) ) 


///Calculate  the  waiting  data  for  each  statement  in  the  stmtgraph. 

(defun  calc-waiting  (stmtgraph) 

(attribute 

'waiting  (stmtgraph-attributes  stmtgraph) 

(macro-relax  stmtgraph 

•'stmt -waiting-in 

•'(lambda  (stmt  new-wait ing-in)  (setf  (stmt-waiting-in  stmt)  new-waiting-in)) 
• 'stmt -wait ing-out) ) ) 


;; /Calculate  the  forced  data  for  each  statement  in  the  stmtgraph. 

(defun  calc-forced  (stmtgraph) 

(attribute 

•forced  (stmtgraph-attributes  stmtgraph) 

(macro-relax  stmtgraph 

•' stmt -forced- in 

•'(lambda  (stmt  new- forced-in)  (setf  (stmt-forced-in  stmt)  new-forced-in)) 

• ' stmt- forced-out 

;inltlal-val  bl 

:root-val  bl 

:comblnator  f'map-b*))) 


;  ? ; ;  + - + 

;;;;!  Calculate  variable  statistics.  [ 

;?;?♦ - ♦ 

;; /Return  true  if  var  Is  referenced  in  stmt, 
(defun  var-referenced?  (var  stmt) 

(or  (equal  (stmt -target  stmt)  var) 

(find  var  (stmt-args  stmt)  /test  •'equal))) 


///Return  true  if  Instance  variables  are  referenced  in  stmtgraph. 

(defun  referenced-lvars?  (stmtgraph) 

(loop  for  stmt  being  the  dinodes  of  stmtgraph 
therels  (or  (lvar?  (stmt -target  stmt)) 

(some  •' (lambda  (arg)  (lvar?  arg))  (stmt-args  stmt))))) 


///Return  a  bmap  of  all  variables  that  are  referenced  in  stmtgraph. 

(defun  referenced-vars  (stmtgraph) 

(let  ( (vars  bO)) 

(loop  for  stmt  being  the  dinodes  of  stmtgraph  do 
(progn 

(if  (var?  (stmt -target  stmt))  (bsetf  vars  (slot-num  (stmt-target  stmt)))) 
(dollat  (slot  (stmt-args  stmt)) 

(if  (var?  slot)  (bsetf  vars  (slot-num  slot)))))) 

vars) ) 
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///Return  a  baap  of  all  variables  that  are  targets  of  sends  In  statgraph. 

(defun  target-vars  (statgraph) 

(let  ((vara  bO) ) 

(loop  for  stat  being  the  dinodes  of  statgraph  do 
(if  (send -operation?  (stat-operat Ion  stat)) 

(If  (var?  (stat -target  stat))  (bsetf  vara  (slot-nun  (stat -target  stat)))))) 

vars) ) 


///Return  true  If  variables  nuabered  vl  and  v2  are  live  slaultaneously  somewhere  In  the  statgraph. 
(defun  vars-lnterfere?  (statgraph  vl  v2) 

(calc-llve  statgraph) 

(and  (/-  vl  v2) 

(loop  for  stat  being  the  dlnodes  of  statgraph 

therels  (let  ((target  (stat-target  stat))) 

(If  (var?  target) 

(let  ((tnua  (slot-nua  target) ) ) 

(or  (and  (•  tnua  vl)  (btest  v2  (stat-llve-out  stat))) 

(and  (•  tnua  v2)  (btest  vl  (stat-llve-out  stat)))))))))) 


;;;|  Slot  substitutions.  | 

;; Substitute  all  occurrences  of  old-slot  In  the  statement  by  new-slot. 

(defun  substltute-stat-slot  (stat  old-slot  new-slot) 

(If  (equal  (stat-target  stnt)  old-slot) 

(setf  (stat-target  stat)  new-slot)) 

(setf  (stmt-args  stat)  (substitute  new-slot  old-slot  (stmt-args  stat)  :test  < 'equal))) 


;; /Substitute  all  occurrences  of  old-slot  in  the  statgraph  by  new-slot. 
(defun  substitute-slot  (statgraph  old-slot  new-slot) 

(loop  for  stat  being  the  dlnodes  of  statgraph  do 

(substltute-stat-slot  stat  old-slot  new-slot) ) 

(altered-dlgraph  statgraph) ) 

;; /Merge  variables  nuabered  vl  and  v2  In  the  statgraph. 

(defun  aerge-vars  (statgraph  vl  v2) 

(unless  (-  vl  v2) 

(substitute-slot  statgraph  (nake-slot  'var  v2)  (make-slot  'var  vl)))) 


////I  Dataflow  optimisation  functions.  I 
;;/;♦ - ♦ 

///Delete  or  replace  statements  defining  dead  variables. 

(defun  delete-dead-defs  (statgraph) 

(calc-llve  statgraph) 

(loop  for  stmt  being  the  dlnodes  of  statgraph  do 
(If  (and  (var?  (stat-target  stat)) 

(not  (btest  (slot-nun  (stat-target  stmt))  (stat-llve-out  stmt)))) 
(case  (stnt -ope rat Ion  stat) 

( (csend  rsend) 

(setf  (stat-target  stat)  nil) 

(altered-dlgraph  statgraph) ) 

( (primitive  new  move) 

(delete-dinode  stat) 

(altered-dlgraph  statgraph)))))) 


-m 


///Delete  unnecessary  MOVE  statements. 

(defun  delete-aoves  (statgraph) 

(loop  for  stat  being  the  dlnodes  of  statgraph  do 
(If  (eq  (stat -operation  stnt)  'move) 

(cond 

((equal  (stat-target  stat)  (stat-arq  stat))  _ ™ 

(delete-d Inode  stmt) 

(altered-dlgraph  statgraph)) 

((and  (var?  (stat-target  stat))  (var?  (stat-arg  stmt))) 

(let  ((to  (slot-ntas  (stmt -target  stmt))) 

(from  (slot -nun  (stat-arg  stat)))) 

(unless  (vars-lnterfere?  statgraph  from  to) 

(aerge-vars  statgraph  from  to) 

(delete-dlnode  stmt) 

(altered-dlgraph  statgraph))))))))  _ ® 


///Delete  unnecessary  TOUCH  statements, 
(defun  delete-touches  (stmtgraph) 
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(calc- forced  stmtgraph) 

(loop  for  stnt  being  the  d Inodes  of  stmtgraph  do 
(If  («q  (stmt -operation  stnt)  ‘touch) 

(lot  ( (arg  (stat-arg  atat))) 

(whan  (or  (not  (var?  arg)) 

(btaat  (alot-nua  arg)  (stmt-forced-in  atat)) 

(btest  (alot-nua  arg)  (atat-auat-forc«  (first  (stmt-successors  stmt) )>) ) 
(dolota-dlnoda  atat) 

(altorad-dlgraph  atatgraph) ) ) ) ) ) 


;;;Make  atat  Into  a  MOVE  of  alot  to  tha  pravloua  targat. 
(dafun  altar-to-aova  (atatgraph  atat  alot) 

(aotf  (atat-oparat ion  atat)  ‘aova) 

(aatf  (atat-aethod  atat)  nil) 

(aotf  (atat-arga  atat)  (Hat  alot)) 

(altorad-dlgraph  atatgraph)) 


;;;Perfora  general  dataflow  optlalzatlona. 

(defun  calc-dflow  (atatgraph) 

(labela 

((df low-type  (atat  alot) 

(and  (var?  alot)  (car  (avref  (atnt-df low-ln  atat)  (alot-nua  alot))))) 

(dflow-data  (atat  alot) 

(and  (var?  alot)  (cdr  (avref  (atat-dflow-ln  atat)  (alot-nua  alot))))) 

(coabine-2-df low  (dflowl  dflow2) 

(map 

'alaple-array 

•'(lambda  (dflow-eltl  dflow-elt2) 

(If  (equal  dflow-eltl  dflow-elt2) 
dflow-eltl) ) 

dflowl 
dflow2) ) 

(combine-df Iowa  (extractor  llat) 

(reduce  •• combine- 2-df low  (map car  extractor  llat))) 

;;Remove  from  dflow  all  entrlaa  that  contain  a  alot  that  aatlsfles  the  predicate  test, 
(purge-dflow  (dflow  teat) 

(dotlaea  (1  (length  dflow) ) 

(dollat  (alot  (cdr  (avref  dflow  l))j 
(If  (funcall  teat  alot) 

(aetf  (avref  dflow  1)  nil))))) 

(stmt-dflow-out  (atmt) 

(let  ((dflow-ln  (copy-aeq  (stmt-df low-ln  stmt)))) 

(If  (var?  (stmt-target  atmt)) 

(aetf  (avref  dflow-ln  (alot-num  (stmt-target  stmt))) 

(case  (atrat-operat Ion  atat) 

(primitive 

(caae  (atmt -method  stmt) 

((not  -  <>  eq  neq)  (cons  (stmt-method  stmt)  (stmt-args  stmt))))) 

(move 

(cons  'move  (stmt-args  stmt )))))) 

(If  (stmt-target  atmt) 

(purge-dflow  dflow-ln  •'(lambda  (alot)  (equal  slot  (stmt-target  stmt))))) 

(If  (send-operatlon?  (stmt -operation  stmt)) 

(purge-dflow  dflow-ln  •'(lambda  (slot)  (lvar?  slot)))) 
dflow-ln) ) ) 

(macro-relax  stmtgraph 

• 'stmt-df low-ln 

•'(lambda  (stmt  new-dflow-ln)  (setf  (stmt -dflow-ln  stmt)  new-df low-ln) ) 

• ' stmt-dflow-out 

:lnltlal-val  (make-array  (list  (stmtgraph-nvars  stmtgraph))  : Initial-element  nil) 
:root-val  (make-array  (list  (stmtgraph-nvars  stmtgraph))  : lnlt ial -element  nil) 
:comblnator  » ' comblne-dflows) 

(loop  for  stmt  being  the  dlnodes  of  stmtgraph  do 
(setf  (stmt-args  stmt) 

(mapca  r 

•'(lambda  (arg) 

(If  (eq  (dflow-type  stmt  arg)  'move) 

(progn 

(altered-dlgraph  stmtgraph) 

(first  (dflow-data  stmt  arg))) 
arg) ) 

(stmt-args  stmt))) 


I 


| 
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(let  ((argl  (stmt -arg  stmt))) 

(caaa  (stmt -operation  atat) 

(prlaltlve 

(caae  (atat-aathod  atat) 

(not 

(caae  (df low-type  atat  argl) 

(not 

(alter-to-aove  stmtgraph  atat  (flrat  (df low-data  atat  argl)))) 

( (-  <>  eg  neq  equal  nequal) 

(aetf  (atat-operatlon  atat)  ‘prlaltlve) 

(aetf  (atat -method  atat)  (oppoalte-coaparlaon  (df low-type  stmt  argl))) 

(aetf  (atat-arga  atat)  (dflow-data  atat  argl)) 

(altered-dlgraph  atatgraph)))))) 

(condition 

(when  (or  (eq  (atat -method  atat)  *bt)  (eq  (stat -met hod  stat)  'bf)l 
(labels 

;; Change  the  branch  condition  to  if-true  if  it  waa  bt  or  lf-false  If  It  was  bf. 
;;Also  change  the  branch  arguaent  to  arg. 

((change-branch  (lf-true  lf-falae  arg) 

(aetf  (atat-aethod  atat)  (if  (eq  (atat-aethod  atat)  ‘bt)  lf-true  lf-false)) 
(aetf  (atat-arga  atat)  (Hat  argl) 

(altered-dlgraph  atatgraph)) 

(change-branch-lf  (slot  lf-true  lf-falae) 

(let  ((dflow-data  (dflow-data  stat  argl))) 

(cond 

((equal  (first  dflow-data)  slot) 

(change-branch  if-true  lf-false  (second  dflow-data))) 

((equal  (eecond  dflow-data)  slot) 

(change-branch  lf-true  lf-falae  (first  dflow-data))))))) 

(case  (df low-type  atat  argl) 

(not  (change-branch  'bf  ‘bt  (flrat  (dflow-data  atat  argl)))) 

(-  (change-branch-lf  • f . (make-slot  ‘const  vO)  ‘br  'bnr)) 

(<>  (change-branch-lf  ‘(.(make-slot  'const  wO)  'bnz  ‘bz)| 

(eq  (change-branch-lf  (aake-alot  'const  wNIL)  ‘bnll  ‘bnnll)) 

(neq  (change-branch-lf  ‘(.(make-slot  ‘const  wNIL)  ‘bnnll  ‘bnll))))))))))) 


. ,  - - - - 

;;;1  Perform  constant  folding.  I 


.-.•Return  t  If  the  given  conditional  branch  would  branch  on  the  given  constant  word, 
?;nll  If  the  conditional  branch  would  not  branch  on  the  given  constant  word, 

;;and  maybe  If  It  cannot  be  determined. 

(defun  branch-teat  (branch  word) 

(ecase  branch 

(bt  (cond 

((equal  word  wTRUE)  t) 

((equal  word  wFM.SE)  nil) 

(t  'maybe))) 

(bf  (cond 

((equal  word  wTRUE)  nil) 

( (equal  word  wFMSE)  t) 

(t  ‘maybe) ) ) 

<bz  (cond 

((equal  word  wO)  t) 

((integer-word?  word)  nil) 

(t  -maybe))) 

(bnz  (cond 

((equal  word  wO)  nil) 

((integer-word?  word)  t) 

(t  ’maybe))) 

(bnll  (equal  word  wNIL) ) 

(bnnll  (not  (equal  word  wNIL))))) 


;;;Fold  constants  in  the  atatgraph. 

(defun  fold-constants  (stmtgraph) 

(loop  for  stat  being  the  dl nodes  of  stmtgraph  do 
(labels 

;;Collect  toqether  all  of  the  constants  that  are  arguments  to  the  primitive  in 
;;stmt  and  reduce  them  using  the  operation  function  which  reduces  two  constants 
.-.-into  one.  Only  Constanta  that  satisfy  type-test  are  eligible.  If  the  reduced 
;;constant  is  the  identity,  don't  include  it  in  the  resulting  list  of  arguments. 
,-,-If  it  is  the  annlhllator,  change  the  operation  to  a  MOVE  of  the  annihilator 
;;to  the  target. 

,-;If  the  simplification  simplifies  the  list  of  arguments  down  to  the  empty  21st, 
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;;the  operation  la  replaced  by  a  HOVE  of  Identity  to  the  target, 
((fold-unordered-prlmitlve  (type-teat  annlhllator  identity  operation) 

(when  (eq  (atait-operatlon  stmt)  'primitive) 

(loop  with  accumulator  -  nil  and  aimpllfled  -  nil 
for  slot  In  (stmt-argm  stmt) 
unless  (and 

(const?  slot) 

(funcall  type-test  (alot-num  slot) ) 

(setq  accumulator 

(If  accumulator 
(progn 

(setq  simplified  t) 

(funcall  operation  accumulator  (alot-num  slot))) 

(alot-num  slot)))) 
collect  slot  Into  slots 
finally  (cond 

((not  accumulator)  nil) 

((equal  annlhllator  accumulator) 

(alter-to-aove  stmtgraph  stmt  (make-slot  'const  annlhllator))) 
((equal  Identity  accumulator) 

(setf  (stmt-args  stmt)  slots) 

(altered-dlgraph  stmtgraph)) 

(simplified 

(setf  (stmt-args  atmt)  (cons  (make-slot  'const  accumulator)  slots)) 
(altered-dlgraph  stmtgraph)))) 

(let  ((slots  (stmt-args  stmt))) 

(cond 

((not  (eq  (stmt -operation  stmt)  'primitive))) 

( (endp  slots) 

(If  Identity  (alter-to-move  stmtgraph  stmt  (make-slot  'const  Identity)))) 

((endp  (cdr  slots))  (alter-to-move  stmtgraph  atmt  (car  slots))))))) 

(fold-unordered-primltlve-tag  (the-tag  annlhllator  Identity  operation) 
(fold-unordered-prlmltlve 
*' (lambda  (word)  (tag-la ?  word  the-tag)) 
annlhllator 
Identity 

• ' (lambda  (wordl  word2) 

(make-word  the-tag  (funcall  operation  (data  wordl)  (data  word2) ) ) , ) ) 

;;If  all  of  the  arguments  to  the  primitive  are  constants  satisfying  type-test, 

;;change  the  operation  Into  a  MOVE  of  a  constant  obtained  by  applying  operation 

;;to  the  constants. 

(fold-ordered-prlmltlve  (type-test  operation) 

(when  (eq  (stmt-operatlon  stmt)  'primitive) 

(loop  for  slot  In  (stmt-args  stmt) 
always  (const?  slot) 

always  (funcall  type-test  (slot-num  slot)) 

collect  (slot-num  slot)  Into  slot-values 

finally  (let  ((result  (apply  operation  slot-values))) 

(If  result  (alter-to-move  stmtgraph  stmt  (make-slot  'const  result))) 
(return  result))))) 

(fold-ordered-prlmltlve-tag  (the-tag  operation) 

(fold-ordered-prlmltlve 
•  • (lambda  (word)  (tag-ls?  word  the-tag)) 

•’(lambda  ((rest  words) 

(let  ((result  (apply  operation  (mapcar  I'fdata  words)))) 

(If  result  (make-word  the-tag  result)))))) 

(fold-ordered-prlmltlve-tag-cond  (the-tag  operation) 

(fold-ordered-prlmltlve 
•'(lambda  (word)  (tag-ls?  word  the-tag)) 

•'(lambda  ((rest  words) 

(If  (apply  operation  (mapcar  •'fdata  words))  wTRUE  wFALSE) ) ) ) 

(fold-ordered-prlmltlve-cond  (operat Ion) 

( fold-ordered-pr Imlt lve 
•'(lambda  (word)  t) 

•'(lambda  ((rest  words) 

(If  (apply  operation  words)  wTRUE  wFALSE))))) 

(case  (stmt-operation  stmt) 

(primitive 

(case  (stmt-method  stmt) 

(not  (fold-ordered-prlmltlve-tag 
tBOOL 

•'(lambda  (d)  (logxor  d  1)))) 

(and  (fold-unordered-prlmitlve-tag  tBOOL  wFALSE  wTRUE  I'logand)) 

(or  (fold-unordered-primltlve-tag  tBOOL  wTRUE  wFALSE  I'loglor)) 

(xor  (fold-unordered-primltlve-tag  tBOOL  nil  wFALSE  #’logxor)) 
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(lognot  (fold-ordered-prlmitive-tag  tlNT  I'lognot)) 

(logand  (fold-unordered-prlmlt  lve-tag  tIHT  wO  •  • .  (make-word  -1)  •■ logand)) 
(log or  (fold-unordered-prlmltlve-tag  tlNT  ' • . (make-word  -1)  wO  I'loglor)) 
(logxor  (fold-unordered-prlmltlve-tag  tlNT  nil  wO  I'logxor)) 

(nag  (fold-ordered-primitlve-tag  tlNT  *•-)) 

(+  (fold-unordered-prlmltlve-tag  tlNT  wO  nil  »■+)) 

(-  (cond 

((equal  (stat-arg2  stmt)  '•■ (make-slot  'const  wO)) 

(alter-to-move  atstgraph  a tat  (stet-arg  stmt))) 

((equal  (stet-arg  sent)  '•.(make-slot  'const  wO) ) 

(sett  (stmt -method  stet)  • neq) 

(setf  (stmt-args  stmt)  (edr  (stmt-args  stmt))) 

(altered-dlgraph  stmtgraph) ) 

(t  (fold-ordered-prlaltlve-tag  tlNT  #•-)))) 

(*  (fold-unordered-prlmltlve-tag  tlNT  nil  el  #•*>) 

(//  (cond 

((equal  (stmt-arg  stmt)  (make-slot  'const  wO)) 

(alter-to-swve  stmtgraph  stmt  '•.(make-slot  ‘const  *0) ) ) 

((equal  (stmt-arg2  stmt)  ••. (make-slot  'const  wl)) 

(alter-to-move  stmtgraph  stmt  (stet-arg  stmt))) 

(t  (fold-ordered-prlmlt lve-tag  tlNT  •’floor)))) 

(mod  (cond 

((equal  (stet-arg  stet)  •». (make-slot  ‘const  wO) ) 

(alter-to-move  stmtgraph  stet  ••. (make-slot  'const  w0))> 

(t  (fold-ordered-prlmitive-tag  tlNT  •‘eod))>) 

(ash  (cond 

((equal  (stmt-arg2  stmt)  '•.(make-slot  ‘const  v0)) 

(alter-to-move  stmtgraph  stet  (stmt-arg  stmt))) 

((equal  (stmt-arg  stmt)  '•.(make-slot  'const  wO) ) 

(alter-to-move  stmtgraph  stet  ‘ •. (make-slot  'const  v0))) 

(t  (fold-ordered-prlmitive-tag  tlNT  •’ash)))) 

(max  (fold-unordered-prlmltlve-tag  tlNT  nil  nil  •'max) 
(fold-unordered-prlmltlve-tag  t BOOL  nil  nil  •'max)) 

(min  (fold-unordered-prlmltlve-tag  tlNT  nil  nil  ('min) 
(fold-unordered-prlmltlve-tag  tBOOL  nil  nil  •‘min)) 

(<  (fold-ordered-prlmltlve-tag-cond  tlNT  •*<) 
(fold-ordered-prlmltlve-tag-cond  tBOOL  ••<)) 

(<-  (fold-ordered-prlmlt lve-tag- cond  tlNT  ••<-) 

( fold-ordered-prlmlt lve-tag-cond  tBOOL  •'<-)) 

(>  (fold-ordered-prleitlve-tag-cond  tlNT  ••>) 

(fold-ordered-prlmlt lve-tag-cond  tBOOL  *■») 

(>-  (fold-ordered-prlmltlve-tag-cond  tlNT  «•>-) 

(fold-ordered-prlmlt lve-tag-cond  tBOOL  ••>-)> 

(•  (fold-ordered-pxlmltlve-tag-cond  tlNT  •■equal) 
(fold-ordered-prlmitlve-tag-cond  tBOOL  •'equal) 
(fold-ordered-prlmltlve-tag-cond  tSTM  •'equal)) 

(<>  (fold-ordered-prlmltlve-tag-cond  tlNT  f'nequal) 
(fold-ordered-prleltlve-tag-cond  tBOOL  •’nequal) 
(fold-ordered-prlmltlve-tag-cond  tSYM  ••nequal)) 

(eq  (fold-ordered-prleltlve-cond  ('equal)) 

(neq  (fold-ordered-prlmltlve-cond  Cnequal)))) 

(condition 

(If  (const?  (stmt-arg  stmt)) 

(let  ((result  (branch-test  (stmt -method  stmt)  (slot-num  (stmt-arg  stmt))))) 
(unless  (eq  result  ’maybe) 

(uni Ink-dinode  stmt  (If  result 

(first  (stmt-successors  stmt)) 

(second  (stmt- successors  stmt)))) 

(delete-dinode  stmt) 

(altered-dlgraph  stmtgraph) ))))))) 

(purqe-unreachables-dlgraph  stmtgraph) ) 


;;;  + - - — — - — - - — - - ♦ 

;;;l  Perform  control  flow  folding.  | 
; ; ;  * - - — - — - - — ♦ 


; ;;Merge  similar  or  Identical  statements  on  both  sides  of  conditionals, 
(defun  merge-forks  (stmtgraph) 

(loop  for  stmt  being  the  dinodes  of  stmtgraph  do 
(If  (eq  (stmt -operation  stmt)  ’condition) 

(let  ((successorl  (first  (stmt-successors  stmt))) 

(successor?  (second  (stmt -successors  stmt))) 

(arg  (stmt-arg  stmt))) 

(when  (and 

(slmllar-out -stmt  successorl  successor?) 

(endp  (edr  (stmt -successors  successorl ) ) ) 

(one-elt-p  (stmt -predecessors  successorl)) 

(one-elt-p  (stmt -predecessors  successor?)) 

(not  (equal  arg  (stmt-target  successorl))) 

(not  (equal  arg  (stmt-target  successor?))) 
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(not  (eq  stmt  successorl) ) 

(not  (eq  a  tat  aucceasor2)> 

(not  (eq  successorl  successor!) ) ) 

(cond 

( (endp  (stmt-successors  successorl) ) 

(delete-dlnode  successor!) 

(delete-dlnode  stmt) ) 

(t 

(unless  (equal  (stmt -target  successorl)  (stmt-target  successor2) ) 
(let  ( (new-var  (gen-var  stmtgraph))) 

(If  (stmt-target  successorl) 

(lnsert-dlnode 
(make-stmt  -.operation  'move 

: target  (stmt-target  successorl) 

:arga  (list  new-var) ) 

successorl 

(first  (stmt-successors  successorl)))) 

(If  (stmt-target  successor2) 

(lnsert-dlnode 
(make-stmt  :operatlon  'move 

:target  (stmt-target  succeasor2) 

:arga  (list  new-var) ) 

successor 

(first  (stmt-successors  successor2) ) ) ) 

(setf  (stmt-target  successorl)  new-var))) 

(delete-dlnode  sue cessor2) 

(delete-dlnode  successorl) 

(lnsert-before-dlnode  successorl  stmt) 

(when  (lvar?  arg) 

(let  ((new-var  (gen-var  stmtgraph) ) ) 

(lnsert-before-dlnode 
(make-stmt  :operatlon  'move 
ttarget  new-var 
:args  (list  arg)) 

successorl) 

(setf  (stmt-args  stmt)  (list  new-var)))))) 

(altered-digraph  stmtgraph)))))) 


n 

t 

A 


; ; ; Merge  similar  or  Identical  statements  In  joins. 

(defun  merge-joins  (stmtgraph) 

(loop  for  stmt  being  the  dinodes  of  stmtgraph  do 
(tagbody 

(all-tuples  ( (predl  pred2)  (stmt -predecessors  stmt)) 

(when  (and 

(slmllar-ln-stmt  predl  pred2) 

(endp  (edr  (stmt-succeasors  predl))) 

(not  (eq  stmt  predl)) 

(not  (eq  stmt  pred2)) 

(not  (eq  predl  pred2))> 

(unless  (equal-stmt  predl  pred2) 

(setf  (stmt-args  predl) 

(mapear 

*' (lambda  (argl  arg2) 

(if  (equal  argl  arg2) 
argl 

(let  ((new-var  (gen-var  stmtgraph))) 
( 1 nsert -before-dl node 
(make-stmt  '.operation  'move 
: target  new-var 
:args  (list  argl)) 

predl) 

( 1 nse  rt -be  f ore-d 1 node 
(make-stmt  : operation  'move 
: target  new-var 
:args  (list  arg2) ) 

pred2) 
new-var) ) ) 

(stmt-args  predl) 

(stmt-args  pred2)))) 

(merge-dlnodes  predl  pred2) 

(altered-digraph  stmtgraph) 

(go  done) ) ) 


done ) ) ) 


i 


n 


;;;Re»ove  conditional  branches  that  branch  to  the  same  place  no  matter  what  the 

; ; {condition  Is.  H 

(defun  fold-condltlonals  (stmtgraph)  — 

(loop  for  stmt  being  the  dinodes  of  stmtgraph  do 
(when  (and 
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(eq  (atat-operation  teat)  'condition) 

(•q  (first  (stmt-succes«ors  stmt))  (aacond  (atat -successors  stmt)))) 
(unlink -dinode  atat  (first  (stmt-successors  atat))) 

(delate-dinode  atat) 

(altered-dlgraph  stmtgraph) ) ) ) 


I  Perform  tall  forwarding.  I 

;; .‘Change  every  CSEND  immediately  followed  by  a  REPLY  of  the  sane  value 
;;;into  an  RSEND  followed  by  a  jump  around  the  REPLY. 

(defun  forward-aenda  (atatgraph) 

(calc-live  atatgraph) 

(loop  for  atat  being  the  dlnodes  of  atatgraph  do 

(let  ((aucceasor  (flrat  (atat-aucceaaora  atat))) 

(target  (atat -target  atat))) 

(when  (and 

(aend-operation?  (atat -operation  atat)) 

(var?  target) 

(eq  (atat-operation  aucceaaor)  'reply) 

(equal  (atat-arg  aucceaaor)  target) 

(not  (btest  (alot-nua  target)  (stmt-11 ve-out  aucceaaor)))) 
(aetf  (stmt -target  atat)  nil) 

(aetf  (atat-operation  atat)  *raend) 

(unllnk-dlnode  atat  aucceasor) 

(llnk-dinode  stmt  (flrat  (stmt-aucceaaora  aucceasor))) 
(altered-dlgraph  atatgraph)))) 

(purge-unreachablea-dlgraph  atatgraph) ) 


I  Split  primitive  operatlona.  I 

- + 

.-.'.-Split  primitive  operatlona  auch  aa  addltlona  and  multiplications  of  more  than 
.-.-.-two  argunenta  into  sequences  of  primitive  operatlona  of  two  arguments. 

(defun  split-primitives  (atmtgraph) 

(labels 

((split-statement  (stmt) 

(If  (and 

(eq  (stmt -operation  atmt)  'primitive) 

(find  (stmt -method  atmt)  • (♦  *  max  min  and  or  xor  logand  logor  logxor) ) 
(>  (length  (stmt-args  stmt))  2)) 

(let*  ( (new- var  (gen-var  atmtgraph)) 

(new-strat  (make-stmt  :operatlon  'primitive 

: method  (stmt -method  stmt) 

: target  (atat -target  atat) 

:args  (cons  new-var  (eddr  (stmt-args  stmt)))))) 
(aetf  (stmt-args  stmt)  (list  (stmt-arg  stmt)  (stmt-arg2  stmt))) 

(setf  (stmt-target  atat)  new-var) 

(Insert -d Inode  new-atmt  stmt  (first  (atmt -successors  stmt))) 
(altered-dlgraph  atmtgraph) 

(split-statement  new-atmt))))) 

(loop  for  stmt  being  the  dlnodes  of  atmtgraph  do  (split-statement  stmt)))) 


.-Transform  CSENDs  to  Instance  variables  Into  CSENDs  to  variables  followed  by  MOVES  into 
;,-;the  Instance  variables, 

(defun  transform-lvar-sends  (atmtgraph) 

(loop  for  stmt  being  the  dlnodes  of  atmtgraph  do 
(If  (and 

(aend-operatlon?  (stmt -operation  stmt)) 

(lvar?  (stmt-target  stmt))) 

(let*  ((new-var  (gen-var  stmtgraph)) 

(new-stmt  (make-stmt  : operation  'move 

(target  (stmt-target  stmt) 

:args  (list  new-var)))) 

(setf  (stmt-target  stmt)  new-var) 

(Insert -dlnode  new-stmt  stmt  (first  (atmt -successors  stmt))) 

(altered-dlgraph  stmtgraph) I ) ) ) 


. ;  + - + 

;;l  Optimize  primitive  operations.  I 


(defun  optimize-prlmltlve  (stmt) 

(labels 

Attempt  to  convert  »  to  a  logical  shift.  Return  true  if  successful. 
( (attempt-*-convert  (argl  arg2) 


L 
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(If  (const ?  argil 

(lot  ((word  (slot-nun  argil)) 

(If  (lntagar-word?  word) 

(let  ((value  (data  word))) 

(when  (power-of-2?  value) 

(setf  (stnt-nethod  atnt)  'ash) 

(setf  (stmt-args  stnt)  (list  arg2  (make-const  (log2  value)))) 
t)))))l) 

(let  ((argl  (stnt-arg  stmt)) 

(arg2  (stat-arg2  stnt))) 

(case  (stnt-nethod  stnt) 

(*  (or  (at tempt -'-convert  argl  arg2) 

(at tempt -'-convert  arg2  argl))) 

(//  (If  (const?  arg2) 

(let  ((word  (slot-nun  arg2))) 

(If  (Integer-word?  word) 

(let  ((value  (data  word))) 

(when  (power-of-2?  value) 

(setf  (stmt-method  stmt)  *ash) 

(setf  (stmt-args  stmt)  (list  argl  (make-const  (-  (log2  value))))))))))))))) 

;;;Optlmixe  primitive  operations  for  the  Idiosyncrasies  of  the  MDP  architecture. 

;;;lfhenaver  possible  put  long  constants  on  the  left  sides  of  binary  operations 
;;;and  short  constants  on  the  right  sides.  Transform  multiplications  by  powers 
;;;of  two  Into  shifts. 

(defun  optimlze-prlmltlves  (atmtgraph) 

(loop  for  stmt  being  the  dlnodes  of  atmtgraph  do 
(If  (eq  (stnt -operation  stmt)  'primitive) 

(optimlze-primitlve  stmt)))) 


;;;+ - ♦ 

;;; I  Stmtgraph  optimizations.  I 

at* - - 

;;Perform  Iterative  stmtgraph  optimizations  until  a  steady  state  is  reached. 

;;Return  the  stmtgraph. 

(defun  1 to rat lve-opt lml ze-stmt graph  (stmtgraph) 

(attribute-steady- state 
(stmtgraph-attrlbutes  atmtgraph) 

(progn 

(when  'delete-dead-defs*  (delete-dead-defs  stmtgraph) ) 

(when  'delete-moves*  (delete-moves  stmtgraph) ) 

(when  ‘delete-touches*  (delete-touches  stmtgraph) ) 

(when  *dflow-optlmlzations*  (calc-dflow  stmtgraph)) 

(when  ‘fold-constants*  (fold-constants  stmtgraph)) 

(when  *forward-sends*  (forward-sends  stmtgraph)) 

(fold-condltlonals  stmtgraph)  ;Thls  must  not  be  disabled,  or  code  generator  will  fall! 
(when  *merge-code* 

(merge- Joins  stmtgraph) 

(merge-forks  stmtgraph) ) ) ) 
stmtgraph) 


;; .'Perform  stmtgraph  post-optimizations  and  transformations. 
;;;Return  the  stmtgraph. 

(defun  transform-stmtgraph  (stmtgraph) 

(split-primitives  stmtgraph) 

(transform-lvar-aends  stmtgraph) 

(If  ‘optimlze-prlmltlves*  (optimlze-prlmltlves  stmtgraph)) 
stmtgraph) 


;;;Perform  all  stmtgraph  optimizations  and  transformations. 
;;;Return  the  stmtgraph. 

(defun  optlmlze-stmtgraph  (stmtgraph) 

(transform-stmtgraph  (lterative-optimlze-stmtgraph  stmtgraph))) 
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/  + - + 

; I  Varlnfo  Record  I 


(defstruct  varlnfo 

nvlocs  /Number  of  variable  locations  In  context  or  nil  If  there  Is  no  context, 
nargs  / Number  of  arguments. 

nivars  /Number  of  Instance  variables  or  nil  if  the  class  Is  a  primitive, 
lvars-used  /True  If  instance  variables  are  referenced, 
varlocs)  /Array  describing  locations  of  variables. 


///Return  a  list  representation  of  the  varlnfo  record. 

(defun  prlnt-varlnfo  (varlnfo) 

(list  'varlnfo 

(list  'nvlocs  (varlnfo-nvlocs  varlnfo) ) 

(list  'nargs  (varlnfo-nargs  varlnfo) ) 

(list  'nivars  (varlnfo-nlvars  varlnfo)) 

(list  'lvars-used  (varlnfo- lvars-used  varlnfo)) 

(cons  "varlocs  (let  ((count  -11) 

(mapcar 

I* (lambda  (v)  (cons  (lncf  count)  v) ) 

(coerce  (varinfo-varlocs  varlnfo)  ’list)))))) 


///  / 1— ———————————————————— 

////|  Assign  variables  to  registers.  I 
///;+ - ♦ 

///Return  the  number  of  unused  registers  and  a  bitmap  of  reserved  registers  for 
///the  statement.  The  number  of  unused  registers  plus  the  number  of  reserved 
///registers  must  be  no  greater  than  4,  but  may  be  less  than  4  if  some  registers 
///are  reserved  but  It  does  not  matter  which  register  Is  reserved. 

(defun  calc-stmt-reg-requlrements  (stmt) 

(ecase  (stmt -operat Ion  stmt) 

((enter  touch  move  condition  exit) 

(values  3  '4(0))) 

( (new  csend  rsend) 

(values  2  '4(0  1))) 

(primitive 

(If  (or  (eq  (stmt -method  Btmt)  •//)  (eq  (stmt -method  stmt)  "mod)) 

(values  2  *410  D) 

//Reserve  an  extra  register  if  the  second  argianent  Is  a  long  constant, 
(values  (if  (and  (const?  (stmt-arg2  stmt)) 

(not  (short-word?  (slot-num  (stmt-arg2  stmt))))) 

2  3) 

"4(0)))) 

(reply 

(values  (If  ‘reply-node*  2  1)  '4(0))))) 


.-//Calculate  the  (stmt-n-unused-regs  stmt),  (strat-reserved-regs  stmt),  and 
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(stat-usad-reqa  stat)  value*  for  each  statement . 

(defun  ca 1 c- rag- raqu 1 reaent a  (stat graph) 

(loop  for  at at  being  the  dlnodea  of  atatgraph  do 

(BUltlple-valua-blnd  (n-unuaed-rega  reaerved-rega)  (calc-stmt-reg-requlrements  stmt) 
(setf  (atat-n-unuaed-rega  stmt)  n-unused-rega) 

(aetf  (stat-reserved-rega  atat)  reaerved-rega) 

(setf  (stat-uaed-regs  stmt)  bO)))) 

;;;Asaign  as  many  variables  present  In  the  vars-to-allocate  bmap  to  registers  as  possible. 
;;;Return  a  tnap  of  all  variables  that  were  successfully  assigned  to  registers. 

(defun  asslgn-regs  (atatgraph  varlnfo  vars-to-allocate) 

(calc-llve  atatgraph) 

(calc-reg-regulraaenta  atatgraph) 

(let  ( (asslgned-vara  bO) 

(priority-list 

(loop  for  var  being  the  bits  of  vars-to-allocate  collect 
(loop  for  stat  being  the  dlnodes  of  atatgraph 

count  (btest  var  (stmt-live-ln  stmt))  into  nllve 
count  (var-referenced?  (make-slot  'var  var)  stat)  Into  nrefs 
finally  (return  (cons  var  (/  (float  nrefs)  (max  nllve  nrefs)))))))) 
(sort  priority-) 1st  »•>  :key  I'cdr) 

(doll st  (var-palr  priority-list  aaslgned-vars) 

(let  ((var  (car  var-palr)) 

(posslble-regs  *t((0  3)))) 

(If 

(loop  for  stat  being  the  dinodes  of  statgraph  do 
(when  (btest  var  (atat-live-ln  stat)) 

(if  (zerop  (stmt-n-unused-regs  stmt)) 

(return  nil) 

(setq  posslble-regs  (b-  posslble-regs  (b+  (stmt-reserved-regs  stmt) 

(stmt-used-regs  stmt))))) 

(If  (beapty  posslble-regs) 

(return  nil))) 
finally  (return  t)l 
(let  ( (the-reg  (blow  posslble-regs) ) ) 

(loop  for  stat  being  the  dinodes  of  statgraph  do 
(when  (btest  var  (stat-llve-in  stat)) 

(decf  (stat-n-unused-regs  stat)) 

(bsetf  (stat-usad-rega  atat)  the-reg))) 

(setf  (svref  (varlnfo-varlocs  varlnfo)  var)  (aake-loc  'reg  the-reg!) 

(bsetf  asalgned-vars  var))))))) 


*  »  *  f  ’ 

Allocate  locations  to  variables.  | 

; ;  ? ;  + - + 

;;Flnd  a  coloring  for  the  graph  given  by  the  edge-matrix. 

;;  Edge-matrix  must  be  a  square,  symmetric,  bit  matrix  in  which  bit  (l,j)  Is 
;;  set  Iff  there  Is  an  edge  between  nodes  1  and  j. 

;;  Nodes  Is  a  bmap  with  the  bits  set  for  the  nodes  in  edge-matrix  which  are 
//  to  be  considered  for  coloring.  The  other  nodes  are  Ignored. 

;;Return  an  array  giving  the  color  assignment  of  each  node  between  0  and 
;;{1-  (array-dimension  edge-matrix  0))  and  the  number  of  colors  used  to  make  the 
; /assignment .  The  nodes  specified  in  the  nodes  bmap  are  assigned  colors  such  that 
;;no  two  nodes  connected  by  an  edge  are  assigned  the  same  color.  The  colors  are 
; /positive  Integers  starting  at  0.  The  nodes  not  specified  in  the  nodes  bmap  are 
; /assigned  nil  colors. 

(defun  color-graph  (edge-matrix  nodes) 

(let*  ((dim  (array-dimension  edge-matrix  0)) 

; /Edge-counts  gives  the  number  of  edges  left  for  each  node. 

(edge-counts  (make-array  (list  dim)  /element-type  'integer)) 

(assignments  (make-array  (list  dim)  /initial-element  nil))) 

(labels 

( (color-graph-rec  (nodes) 

(if  (bempty  nodes) 

0 

(let  ( (mln-count  -1) 
index) 

(loop  for  i  being  the  bits  of  nodes  do 

(when  (>  (svref  edge-counts  i)  min-count) 

(setf  min-count  (svref  edge-counts  i)) 

(setf  index  1))) 

(let  ( (new-nodes  (bclr  index  nodes))) 

(loop  for  1  being  the  bits  of  new-nodes  do 
(if  (-  (bit  edge-matrix  i  index)  1) 

(decf  (svref  edge-counts  i)))) 

(let  ( (ncolors  (color-graph-rec  new-nodes)) 

(interfering-colors  bO)) 

(loop  for  i  being  the  bits  of  new-nodes  do 
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(If  (-  (bit  edge-matrix  1  Index)  1) 

(bsetf  interfering-colors  (svref  assignments  1)))) 
(let  ((new-color  (blow  (bnot  interfering-colors)))) 

(setf  (svref  assignawnts  index)  new-color) 

(max  ncolors  (1+  new-color))))))))) 

(loop  for  i  being  the  bits  of  nodes  do 
(setf  (svref  edge-counts  i) 

(loop  for  J  being  the  bits  of  nodes 
sum  (bit  edge-matrix  1  j) ) ) ) 

(let  ((ncolors  (color-graph-rec  nodes))) 

(values  asslgnamnts  ncolors)) I) ) 


;;;Assign  variables  to  context  locations  in  the  vlocs  array  using  a  very  simple  approach. 
;;;Return  the  number  of  locations  used. 

(defun  simple-asslgn-vlocs  (stmtgraph  varlnfo) 

(dot laws  (var  (statgraph-nvars  stmtgraph)) 

(unless  (svref  (varlnfo-varlocs  varlnfo)  var) 

(setf  (svref  (varlnfo-varlocs  varlnfo)  var) 

(atfke-loc  ‘vloc  I*  var  f irst-context-slot-num) ) ) ) ) 

(statgraph-nvars  stmtgraph) ) 


;;;Asslgn  variables  to  context  locations  in  the  vlocs  array  by  calculating  a  variable 

;;; interference  graph  and  trying  to  pack  as  many  variables  into  as  few  locations  as  possible. 

;;;Return  the  maaber  of  locations  used. 

(defun  alloc-vlocs  (stmtgraph  varlnfo  vars-to-al locate) 

(calc-live  stmtgraph) 

(calc-waiting  stmtgraph) 

(let  ((interference-matrix  (make-array  (list  (stmtgraph-nvars  stmtgraph) 

(atmtgraph-nvars  stmtgraph) ) 

:element-type  ‘bit 
tinltlal-element  0))) 

(loop  for  stmt  being  the  dinodes  of  stmtgraph  do 
(let  ((target  (stmt-target  stmt))) 

(if  (var?  target) 

(let  (Id  (slot-num  target)}) 

(loop  for  1  being  the  bits  of  (b*  (bclr  d  vara-to-allocate) 

<bt  (stmt -live-out  stmt) 

(stmt-waltlng-out  stmt)))  do 


(progn 

(setf  (bit  interference-matrix  1  d)  1) 

(setf  (bit  interference-matrix  d  1)  1))))))) 
(multlple-value-blnd  (assignments  ncolors)  (color-graph  interference-matrix 

vars-to-al locate) 


(loop  for  1  being  the  bits  of  vars-to-allocate  do 
(setf  (svref  (varlnfo-varlocs  varlnfo)  i) 

(make-loc  'vloc  (+  (svref  assignments  1)  f 1 rst-context-slot-num) ) ) ) 

ncolors) ) ) 


?;;♦ - ♦ 

t;; l  Calculate  the  varlnfo  record.  I 
III* - * 

;;Return  the  varlnfo  record.  Modify  the  stmtgraph  as  appropriate. 

(defun  new-varlnfo  (stmtgraph  nargs  nlvars) 

(let  ((varlnfo  (make-varlnfo 
:nargs  nargs 
inlvars  nlvars 

:lvars-used  (if  *optimlie-lvar-access* 

(referenced-lvars?  stmtgraph) 
nlvars) 

(varlocs  (make-array  (list  (stmtgraph-nvars  stmtgraph))  : Initial-element  nil))) 
(vars-to-allocate  (referenced-vars  stmtgraph))) 

(if  "reg-varlables* 

(setq  vars-to-allocate  (b-  vars-to-allocate 

(asslgn-regs  stmtgraph  varlnfo 

<b-  vars-to-allocate  (target-vars  stmtgraph)))))) 

(let  ((nvlocs  (If  "optlmlse-vars* 

(alloc-vlocs  stmtgraph  varlnfo  vars-to-allocate) 

(simple-asslgn-vlocs  stmtgraph  varlnfo)))) 

(If  (>  nvlocs  (-  max-context-site  first -context-slot-num) ) 

(cerror  "Compile  anyway"  "Too  many  local  variables  and  temporaries:  -D  (-D  maximum)" 
nvlocs  (-  max-context-site  first-context-slot -num) ) ) 

(if  (and  *optlmlte-null-contexts*  (terop  nvlocs)) 

(setq  nvlocs  nil)) 

(setf  (varlnfo-nvlocs  varlnfo)  nvlocs)) 
varlnfo) ) 
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; ; ; ;  + - + 

tilt  I  Priu  rout  ines  I 

(defat  ruct  (frame  (:copi«r 
varlnfo 

(regs  (make-array  •«))) 
(lockmap  bO  :typ«  baiap) 
(waiting  bO  /type  bmap) 
(nigrata  t) 

(lru-regs  • (0  1  2  3))) 


copy-frastel) ) 

/Global  varlnfo  assignments. 

/Array  of  known  register  slot  values. 

/ftaap  of  register  locks. 

•  Baiap  of  unforced  slots. 

/True  if  the  Instance  object  could  have  migrated  away. 

/List  of  registers  in  order  from  most  to  least  recently  used. 


(defvar  ‘frame*) 

///Bring  the  register  rag  to  the  front  of  lru-rega.  j 

///Return  the  new  lru-regs. 

(defun  brlng-ts-front  (rag  lru-regs) 

(if  *usa-lru-register-allocation*  (eons  reg  (remove  reg  lru-regs)) 
lru-regs) ) 


///Add  a  temporary  binding  of  slot  to  reg  in  frame. 

(defun  add-temp-locatlon  (reg  slot) 

(if  slot  (push  slot  (svref  (frame-regs  ‘frame*)  (reg-num  reg)))))  | 

///Add  a  temporary  binding  of  slot  to  reg  in  frame. 

///Purge  all  existing  temporary  bindings  referring  to  reg  in  frame. 

(defun  nnw-temp- location  (reg  slot) 

(setf  (svref  (frame-regs  ‘frame*)  (reg-num  reg))  (and  slot  (list  slot)))) 

///Purge  all  temporary  bindings  referring  to  reg  in  frame. 

(defun  trash-reg  (reg) 

(setf  (svref  (frame-regs  ‘frame*)  (reg-num  reg))  nil))  I 

///Purge  all  temporary  bindings  of  slot  in  frame. 

(defun  purge-temp-locatlons  (slot) 

(dotlmes  (r  4) 

(setf  (svref  (frame-regs  ‘frame*)  r) 

(delete  slot  (svref  (frame-regs  ‘frame*)  r)  /test  f'equal) >>) 

///Purge  all  temporary  bindings  referring  to  llocs  in  frame. 

(defun  purge-lloc-locatlons  ()  | 

(dotlmes  (r  4) 

(matt  (svref  (frame-regs  ‘frame*)  r) 

(delete-lf  ('(lambda  (slot)  (lvar?  slot))  (svref  (frame-regs  ‘frame*)  r) ) ) ) ) 

///Return  the  permanent  location  of  slot  in  frame. 

(defun  the-locatlon  (slot) 

(let  ( (num  (slot-num  slot))) 

(case  (slottype  slot) 

(var  (svref  (varlnfo-varlocs  (frame-varinfo  ‘frame*))  num))  | 

(arg  (make-loc  'aloe  (♦  num  flrst-arg-slot-num) ) ) 

(lvar  (make-loc  'Hoc  (+  num  f  lrst-instance-slot-num) ) ) 

(const  (make-loc  (if  (short-word?  (slot-num  slot))  'sconst  ’lconst)  num)) 

(self  selfloc) 

(loc  num) 

(t  (error  ‘Bad  slot:  -S*  slot))))) 

///Return  true  if  the  register  contains  the  value  of  the  slot  In  the  frame. 

(defun  reg-contalns  (reg  slot)  j 

(and  *optlmlie-local-regs* 

(find  slot  (svref  (frame-regs  ‘frame*)  (reg-num  reg))  /test  f'equal))) 

///Return  a  list  of  all  locations  referring  to  slot  in  frame. 

(defun  locations  (slot) 

(let  ((locllst  (list  (the-locatlon  slot)))) 

(If  *optlmiie-locsl-regs* 

(dotlmes  (r  4) 

(If  (find  slot  (svref  (frame-regs  ‘frame*)  r)  /test  f'equal)  | 

(push  (make-loc  'reg  r)  locllst)))) 
locllst) ) 

///Allocate  a  temporary  register  that  Is  not  one  of  the  forbidden  registers. 

(defun  alloc-reg  (tkey  (forbidden  bO)) 

(let  ((bad  (b*  (frame-lockmap  “frame*)  forbidden)! 
excellent 
good ) 

(dollst  (r  (frame-lru-regs  ‘frame*))  | 

(unless  (btest  r  bad) 

(If  (or  (rerop  r)  (svref  (frame-regs  ‘frame*)  r) ) 

(setq  good  rl 

(setq  excellent  r) ) ) ) 
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(let  ((reg  (or  excellent  good))) 

(If  reg 
(progn 

(setf  (frame-lru-regs  ‘frame*)  (bring -to- front  reg  (frame-lru-regs  ‘frame*))) 
(make-loc  'reg  reg)) 

(error  "Can't  allocate  register"))))) 

; ; ; Lock  the  register  reg,  which  prevents  It  from  being  allocated  until  It  is 
;;; unlocked. 

(defun  lock-reg  (reg) 

(bsetf  (frame-lockaap  ‘frame*)  (reg-num  reg))) 

;;;Onlock  the  register.  Do  nothing  if  It  was  previously  unlocked. 

(defun  unlock-reg  (reg) 

(bclrf  (frame-lockmap  ‘frame*)  (reg-num  reg))) 

;;;Mark  the  slot  as  being  unforced. 

(defun  unforce  (slot) 

(and  (var?  slot) 

(bsetf  (frame-waiting  ‘frame*)  (slot-num  slot)))) 

;;;Mark  the  slot  as  being  forced. 

(defun  force  (slot) 

(and  (var?  slot) 

(bclrf  (frame-waiting  *frame‘)  (slot-num  slot)))) 

;;;Return  true  if  slot  is  a  potentially  unforced  context  variable. 

(defun  unforced  (slot) 

(and  (var?  slot) 

(or  (not  ‘optlmlze-forces*) 

(btest  (slot-num  slot)  (frame-waiting  ‘frame*))))) 

;;;Return  a  list  of  all  potentially  unforced  context  variable  slots. 

(defun  unforced-slots  () 

(let  ((varlocs  (varinfo-varlocs  (frame-varinfo  ‘frame*)))) 

(loop  for  1  below  (length  varlocs) 

if  (and  (vloc?  (svref  varlocs  1)) 

(unforced  (make-slot  'var  1))) 
collect  (make-slot  'var  1)))) 

Assert  that  the  Instance  object  could  have  migrated  away. 

(defun  could-migrate  () 

(purge- 1 loc-locat ions) 

(setf  (frame-migrate  ‘frame*)  t ) ) 

;;;Assert  that  the  Instance  object  could  not  have  migrated  away. 

(defun  could-not-mlgrate  () 

(setf  (frame-migrate  ‘frame*)  nil)) 

;;;Return  true  if  the  Instance  object 'could  have  migrated  away. 

(defun  migratep  () 

(or  (not  ‘optlmlze-mlgrate*) 

(frame-migrate  ‘frame*))) 

;;; Return  the  number  of  variable  locations  in  context. 

(defmacro  get-nvlocs  0 

' (varlnfo-nvlocs  (frame-varinfo  ‘frame*))) 

;;;Return  the  size  of  the  message  that  started  this  method. 

(defun  get-magsize  () 

(+  msg-overhead  1  (varlnfo-nargs  (frame-varinfo  ‘frame*)))) 

;;;Return  the  number  of  Instance  variables  or  nil  if  the  class  is  atomic. 

(defmacro  get-nlvars  () 

• (varlnfo-nlvars  (frame-varinfo  ‘frame*))) 

;;;Return  true  if  Instance  variables  are  used. 

(defun  lvars-used?  0 

(varinfo-lvars-used  (frame-varinfo  ‘frame*))) 

(eval-when  (compile  load  aval) 

(if  ‘reply-node* 

(progn 

;;;Return  the  reply  ID. 

(defun  reply-ID  () 

(make-loc  'aloe  (-  (get-msgsi ze)  3))) 

;;;Return  the  reply  slot. 

(defun  reply-slot  0 

(make-loc  'aloe  (-  (get-msgsi ze)  2))) 

;;;Return  the  reply  node  number. 

(defun  reply-node  () 
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(make-loc  'aloe  (-  (get-msgsize)  1)))) 
(progn 

; ; ; Return  the  reply  ID. 

(defun  reply-ID  () 

(make-loc  'aloe  (-  (get-msgsize)  2) ) ) 
.-.•.•Return  the  reply  slot. 

(defun  reply-slot  0 

(aake-loc  'aloe  (-  (get-asgslze)  1)))))) 


;;;Set  the  register  values  In  regsl  to  be  the  Intersection  of  the  values  In  regsl 
;;;and  regs2. 

(defun  merge -frame -rags  (regsl  regs2) 

(dotlaes  (r  4) 

(setf  (svref  regsl  r) 

(copy-list  (nintersection  (svref  regsl  r) 

(svref  regs2  r)  :test  •’equal))))) 

;;;Merge  the  two  frames  to  produce  a  frame  containing  the  comnon  bindings  of 
;;;the  two  frames.  If  either  frame  Is  nil,  a  frame  equivalent  to  the  other  frame 
;;,‘ls  returned.  Framel  may  be  destructl vely  modified.  The  resulting  frame  does  not 
;;;have  any  common  elements  with  frame2. 

(defun  merge-frames  (framel  frame2) 

(merge-f rame-regs  (frame-regs  framel)  (frame-regs  frame2)) 

(setf  (frame-lockmap  framel)  (b*  (frame-lockmap  framel)  (frame-lockmap  frame2))) 

(setf  (frame-waiting  framel)  (b+  (frame-waiting  framel)  (frame-waiting  frame2))) 

(setf  (frame-migrate  framel)  (or  (frame-migrate  framel)  (frame-migrate  frame2))) 

framel ) 

;;  .‘Merge  the  frame  Into  'frame*. 

(defun  merge-frame  (frame) 

(setq  'frame*  (merge-frames  'frame*  frame))) 

;;; Make  a  copy  of  the  registers  array. 

(defun  copy-frame-regs  (regs) 

(map  ’(simple-vector  4)  I’copy-llst  regs)) 

;;;Make  a  copy  of  the  frame. 

(defun  copy-frame  (frame) 

(let  ((copy  (copy-framel  frame))) 

(setf  (frame-regs  copy)  (copy-frame-regs  (frame-regs  frame))) 
copy) ) 

;;;Return  a  copy  of  'frame*. 

(defun  current-frame  () 

(copy-frame  'frame')) 


;;;Calculate  a  frame  for  the  statement  from  It  and  Its  predecessors. 

(defun  gen-frame  (stmt  varlnfo) 

(let  ((frame  (make-frame 

:varlnfo  varlnfo 
:reg8  nil 

llockmap  (If  *reg-variables* 

(stmt-used-regs  stmt) 
bO) 

:walting  (If  'optlmlze-forces* 

(stmt -waitlng-ln  stmt) 
bl) 

:mlgrate  nil) ) ) 

(dollst  (predecessor  (stmt -predecessors  stmt)) 

(If  (or  (root?  predecessor)  (null  (stmt-frame  predecessor))) 

(progn 

(setf  (frame-regs  frame)  (make-array  ’(4))) 

(setf  (frame-migrate  frame)  t)l 
(let  ((pred-frame  (stmt-frame  predecessor))) 

(setf  (f rame-lru-regs  frame)  (frame-lru-regs  pred-frame)) 

(If  (frame-regs  frame) 

(merge-f rame-regs  (frame-regs  frame)  (frame-regs  pred-frame)) 

(setf  (frame-regs  frame)  (copy-frame-regs  (frame-regs  pred-frame)))) 
(If  (frame-migrate  pred-frame) 

(setf  (frame-migrate  frame)  t))))) 

(unless  (ln-same-baslc-block?  (car  (stmt -predecessors  stmt))  stmt) 

(setf  (svref  (frame-regs  frame)  0)  nil)) 
frame) ) 


-Return  the  "best'  location  out  of  the  given  list  that  Is  not  one  of  the  S 

.‘.‘.•registers  indicated  In  the  forbidden  bmap. 

(defun  best-loc  (loc-list  ikey  (forbidden  bO)) 

(let  (excellent  very-good  good  poor) 
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(dollst  (loc  loc-llst) 

(cond  ( (red?  loc) 

(union  (btest  (reg-num  loc)  forbidden) 

(If  (btest  (loc-nua  loc)  (frame- lockup  ‘frame*)) 

(aatq  axcallanc  loc)  ;Prafar  locked  reglatera  to  unlocked  ones, 
(setq  very-good  lac)))) 

( (aconst?  loc)  (aetq  good  loc)) 

(t  (aetq  poor  loc)))) 

(or  excellent  very-good  good  poor))) 


;;;;+ - ♦ 

lilt I  Instruction  generator  routines  I 

Sill* - - 

(defvar  *flrat-lnat*) 

(defvar  *laat-lnata*) 

(defvar  *prev‘)  /Previous  Instruction  In  code  sequence. 

;;; Call  f  to  generate  Instructions  under  the  given  frame. 

///Return  three  values: 

III  the  first  Instruction, 

III  a  list  of  last  Instructions, 

111  and  the  frame. 

(defun  gen-lnsts  (f  frame) 

(let  ( (‘flrst-lnst*  nil) 

(‘last-lnsts*  nil) 

(•frame*  frame)) 

(funcall  f) 

(values  *flrst-lnst*  *last-lnsts*  ‘frame*))) 

///Link  the  Instruction  to  the  end  of  the  generated  Instructions. 

///Return  Inst. 

(defun  gen  (Inst) 

//Create  static  links. 

(llnk-lnst  *prev*  Inst) 

(setq  *prev*  Inst) 

//Create  dynamic  links. 

(dollst  (last  *last-lnsts*)  (link-dinode  last  Inst)) 

(If  (null  *flrst-lnst*)  (setq  *flrst-lnst*  Inst)) 

(setq  *last-lnsts*  (list  Inst)) 

Inst) 

///Generate  the  Instruction  using  arguments  as  Inputs  to  new-lnst. 

///Return  the  Instruction. 

(defmacro  gen-lnst  (treat  arguments) 

(list  'gen  (cons  'new-lnst  arguments))) 

///Indicate  that  the  next  Instruction  should  not  be  linked  to  the  current  one. 
(defun  gen-break  () 

(setq  *last-lnsts*  nil)) 

///Indicate  that  the  Instruction  given  as  an  argument  Is  a  branch  to  the  current 
///position.  It  will  be  linked  to  the  next  Instruction  generated. 

(defun  gen-merge  (Inst) 

(push  Inst  *last-lnsts*) ) 


III  Generate  an  Instruction  to  read  arc  Into  dst,  which  must  be  a  register. 

///If  sre  Is  a  lconst,  dst  must  be  regO. 

(defun  gen-read  (sreloe  srcslot  dstreg) 

(unless  (or  (equal  sreloe  dstreg)  (reg-contalns  dstreg  srcslot)) 

(If  (lconst?  sreloe) 

(progn 

(assert  (equal  dstreg  regO) ) 

(gen-lnst  :op  'dc  :srcl  sreloe  /writes  'I(O))) 

(gen-lnst  :op  'move  :srcl  sreloe  :dst  dstreg))) 

(new-temp-locatlon  dstreg  srcslot) 

(If  (Hoc?  sreloe)  (could-not -migrate) ) 

(when  (unforced  srcslot) 

(could-mlgrate) 

(force  srcslot))) 

///Generate  an  Instruction  to  read  a  constant  or  a  special  register.  The  fact 
///that  the  constant  or  special  register  was  read  Into  dstreg  Is  kept  in  the  frame  until 
///dstreg  Is  altered,  allowing  elimination  of  subsequent  reads  of  the  same  constant  or 
///special  register  into  the  same  dstreg.  The  constant  or  special  register  must  therefore 
///be  immutable. 

(defun  gen-read-speclal  (sreloe  dstreg) 

(gen-read 

sreloe 
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(can  (loctype  srcloc) 

( (icoiut  lconst)  (make-slot  'const  (loc-nua  srcloc))) 

(t  (aaka-alot  *loc  srcloc))) 
dstreg) ) 

;;;Ganarats  Instruction (s)  to  road  the  value  In  srcalot  Into  dstreg.  The  read  is 
;;;d tract  except  when  srcalot  Is  a  lconst,  in  which  case  It  Is  read  into  regO  first 
;;;if  can-trash-regO  Is  true  and  an  error  is  generated  otherwise. 

(defun  gen-read-slot  (srcslot  dstreg  (optional  can-trash-regO) 

(let  ((srcloc  (best-loc  (locations  srcslot!))) 

(if  (and  can-trash-regO  (lconst?  srcloc)  (not  (equal  dstreg  regO))) 

(progn 

(gen-read  srcloc  srcslot  regO) 

(gen-read  regO  srcslot  dstreg) ) 

(gen-read  srcloc  srcslot  dstreg)))) 

;; /Generate  an  Instruction  to  write  src,  which  must  be  a  register,  to  dst. 

(defun  gen-write  (srcreg  dstloc  dstslot) 

(unless  (equal  srcreg  dstloc) 

(gen-lnst 
: op  ‘move 
:srcl  srcreg 
:dst  dstloc)) 

(if  (Hoc?  dstloc)  (could-not-migrate) ) 

(purge-temp-locations  dstslot) 

(if  (reg?  dstloc)  (new-tamp-locatlon  dstloc  dstslot)) 

(add-teap-location  srcreg  dstslot) ) 

;;;Generate  an  instruction  to  make  a  system  call. 

;;;R eads  and  writes  are  optional  parameters  that  specify  the  registers  that  the 
;; /system  call  reads  and  writes/trashes. 

(defun  gen-call  (trapnum  (key  (reads  '*())  (writes  '*())) 

(could-migrate) 

(gen-lnst  :op  ‘call  :srcl  (make-loc  ‘sconst  trapnum)  :reads  reads  /writes  writes) 
(loop  for  r  being  the  bits  of  writes  do  (trash-reg  (make-loc  'reg  r) ) ) ) 


mi* - - - + 

lilt  I  Generate  an  lnstgraph.  I 


///linearize  and  convert  the  stmtgraph  into  a  module  containing  an  MDP  instruction  digraph. 
///Return  the  module. 

(defun  complle-stmtgraph  (stmtgraph  nargs  nlvars) 

(gen-stmt graph-1 nets  stmtgraph  (new-varlnfo  stmtgraph  narga  nlvars))) 

///Linearize  and  convert  the  stmtgraph  and  varlnfo  Into  a  module  containing  an 
///MOP  Instruction  digraph. 

///Return  the  module. 

(defun  gen-stmtgraph-lnsts  (stmtgraph  varlnfo) 

(let*  ( (m  (make-module)) 

(*prev*  m)> 

(setf  (module-digraph  m) 

(map-digraph 

stmtgraph 

•'(lambda  (stmt)  (gen-f rame-insts  stmt  varlnfo)) 

/order  (linearize  stmtgraph))) 

(llnk-lnst  *prev*  m)  /Close  the  loop, 
m) ) 

III  Returns  the  Instructions  generated  for  stmt. 

(defun  gen-f rame-insts  (stmt  varlnfo) 

(multlple-value-blnd  (first  last  frame) 

(gen-lnsts  •' (lambda  ()  (gen-stmt-lnsts  stmt)) 

(gen-frame  stmt  varlnfo)) 

(setf  (stmt-frame  stmt)  frame) 

(values  first  last))) 


11  Returns  the  Instructions  generated  for  stmt  starting  from  ‘frame*. 
II  In  this  and  all  following  procedures  ‘frame*  is  modified  to  reflect 
ll  the  state  at  the  end  of  the  statement. 

(defun  gen-stmt-lnsts  (stmt) 

(ecase  (stmt -operation  stmt) 

(enter  (gen-enter-lnsts  stmt)) 

( (csend  rsend)  (gen-send-inst s  stmt)) 

(primitive  (gen-primitlve-lnsta  stmt)) 

(touch  (gen-touch-lnsts  stmt)) 

(move  (gen-move-lnsts  stmt)) 

(new  (gen-new-insts  stmt)) 

(condition  (gen-cond-lnsts  stmt)) 
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(reply  (gen-reply- inst a  sent)) 
(exit  (gen-exlt-insts  stnt)))) 


(defun  gen-aove-lnst*  (at at) 

(unleaa  (equal  (stat-target  stnt)  (stnt-arg  stnt)) 

(gen-force  (stnt -target  atnt)))  ,-Avold  putting  target  Into  limbo. 

(let*  ( (srcslot  (stnt-arg  stnt) > 

(srclocs  (locations  srcslot)) 

(sreloe  (best-loc  srclocs) ) 

(dstslot  (stnt -target  stnt)) 

(dstloc  (the-locatlon  dstslot) ) ) 

(unless  (find  dstloc  srclocs  :test  •' equal) 

(case  (loctype  dstloc) 

(reg 

(gen— read-slot  srcslot  dstloc  t) 

(purge-taaip- locations  dstslot) ) 

( 'vloc  Hoc) 

(case  (loctype  sreloe) 

(reg 

(gen-write  sreloe  dstloc  dstslot) ) 

< (sconst  1 const  sloe  aloe  iloc) 

(gen-read  sreloe  srcslot  regO) 

(gen-write  regO  dstloc  dstslot))))))) 
vindicate  that  all  source  registers  contain  the  destination  value  too. 
(doliat  (sreloe  (locations  (stnt-arg  stnt))) 

(if  (reg?  sreloe)  (add-tenp-location  sreloe  (stat-target  stnt))))) 

(defun  gen-prlaltive-lnsts  (stat) 

(unless  (find  (stat-target  stat)  (stnt-args  stnt)  :test  f ’equal) 
(gen-force  (stat-target  stat)))  ;Avold  putting  target  into  limbo. 

(let  ( (method  (stnt -net hod  stnt))) 

(unless 

(case  (length  (stnt-args  stat)) 

(1  (let  ( (unary-nane  (cadr  (assoc  method 

• ( (neg  nag) 

(not  not) 

(lognot  not) ) ) ) ) ) 

(cond 

(unary-nane  (gen-unary-prlnltlve-lnsta  unary-name  stmt)  t) ) ) ) 
(2  (let  ((binary-name  (cadr  (assoc  method 

’  ( (and  and) 

(or  or) 

(sor  xor) 

(logand  and) 

(logor  or) 

(logxor  xor) 

(+  add) 

(-  sub) 

(*  mul) 

(max  max) 

(nin  aln) 

(ash  ash) 

(<  It) 

(<-  le) 

(>  gt) 

(>-  ge) 

(-  equal) 

(<>  nequal) 

(eq  eq) 

(neq  neq) ) ) ) ) ) 

(cond 

(binary-name  (gen-blnary-primitive-insts  binary-name  stmt)  t) 
( (eq  method  •//)  (gen-dlvide-instx  stmt  nil)  t) 

( (eq  method  ’mod)  (gen-dlvlde-lnsts  stmt  t)  t))>>) 

(error  "Bad  primitive:  -S  -S"  method  (stmt-args  stmt))))) 


;;  Allocate  a  register  for  the  calculation  of  a  value  to  be  stored  in  dstslot. 

;;  If  dstslot  is  a  register,  it  is  used;  otherwise,  a  new  register  is  allocated. 
;;  The  function  f  should  generate  code  to  calculate  the  value  for  dstslot  and 
;;  store  it  in  the  register  it  receives  as  an  argument. 

;;  Alloc-dst-reg  generates  the  code  generated  by  f  followed  by  code  to  move  the 
;;  resulting  value  to  dstslot,  if  necessary. 

(defun  alloc-dst-reg  (dstslot  f) 

(let  ((dstloc  (the-locatlon  dstslot))) 

(case  (loctype  dstloc) 

(reg 

(funcall  f  dstloc) 

(purge-temp- locations  dstslot) 

(trash-reg  dstloc)) 


116 


Appendix  D 


Complete  Listing  of  the  Compiler 


Instruction  Generator 


((vloc  Hoc) 

( lot  ( (dot  reg  (al loc-rag) ) ) 

(funcall  f  dotrog) 

(gen-write  dotrog  dstloc  dotolot) ) ) ) ) ) 

;;;  Bring  tho  value  In  orcolot  Into  RO  It  it  cannot  be  acceased  as  opO  of  an 
;;;  lnotruction.  Thlo  only  happens  if  arcolot  io  a  lconot. 

;;;  The  function  f  ahould  generate  code  to  uoe  the  value  in  arcolot. 

(defun  alloc-arc-loc  (arcolot  f) 

(lot  ( (orcloc  (beot-loc  (locationo  arcolot)))) 

(if  (lconot?  orcloc) 

(progn  (gen-read  orcloc  arcolot  regO) 

(funcall  f  regO)) 

(funcall  f  orcloc)))) 

;;;  Bring  the  value  in  arcelot  into  a  reglotar  that  is  not  one  of  the  forbidden  registers 
;;;  specified  in  the  forbidden  baup. 

;;;  RO  may  also  be  aodified  (even  if  it  is  forbidden)  if  arcolot  is  a  lconst. 

;;;  The  function  f  ahould  generate  code  to  use  the  value  in  arcslot. 

(defun  alloc-orc-reg  (arcslot  f  (key  (forbidden  bO)) 

(labels 

( (alloc-orc-reg-aub  (best orcloc  srclocs) 

(let  ((orcloc  (best-loc  srclocs  : forbidden  forbidden))) 

(if  (reg?  orcloc) 

(funcall  f  orcloc) 

(tat  ( (srcreg  (alloc-reg  :forbidden  forbidden))) 

(gen-read  beotorcloc  srcslot  srcreg) 

(funcall  f  srcreg)))))) 

(let*  ((srclocs  (locations  srcslot)) 

(orcloc  (best-loc  srclocs) ) ) 

(if  (lconst?  orcloc) 

(progn  (gen-read  srcloc  srcslot  regO) 

(alloc-src-reg-sub  srcloc  ‘1.(1181  regO))) 

(alloc-src-reg-sub  srcloc  srclocs))))) 

;;;  Generate  the  instructions  for  the  unary  statement  stmt  using  the  Instruction 
;;;  in  op. 

(defun  gen-unary-prlmitive-lnsts  (op  stmt) 

(alloc-arc-loc 
(stmt-erg  stmt) 

•'(lambda  (srcloc) 

(alloc-dst-reg 
(stmt-target  stmt) 

•  '(lambda  (dstloc) 

(could-mlgratel 
(force  (stmt-arg  stmt)) 

(gen-lnst  top  op  tsrcl  srcloc  tdst  dstloc) 

(trash-reg  dstloc)))))) 

;;;lf  reversing  the  operands  of  the  instruction  would  make  it  more  efficient,  return  the 
tfi new  opcode  of  the  instruction.  Otherwise,  return  nil. 

(defun  optlmlze-blnary-order  (op  argl  arg2) 

(let  ( (converse  (cadr  (assoc  op  '  ( (and  and) 

(or  or) 

(xor  xor) 

(add  add) 

(mul  mul) 

(max  max) 

(min  min) 

(It  gt) 

(le  ge) 

(gt  It) 

(ge  le) 

(equal  equal) 

(nequal  nequal) 

(eq  eq) 

(neq  ne q)>)>>) 

(and  converse 

(or  (not  (eq  op  'mul)) 

(integer-const?  argl) 

(integer-const?  arg2) ) 

(let  ((loci  (best-loc  (locations  argl))) 

(loc2  (best-loc  (locations  arg2)))) 

(and  (or  (and  (lconst?  loc2)  (not  (lconst?  loci))) 

(and  (reg?  loc2)  (not  (reg?  loci)))) 
converse) ) ) ) ) 

.'.■/Generate  the  instructions  for  the  binary  statement  stmt  using  the  Instruction  In  op. 
(defun  gen-blnary-prlmlt Ive-lnsts  (op  stmt) 

(let*  ((argl  (stmt-arg  stmt)) 

(arg2  (stmt-arg2  stmt)) 
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(order  (and  ‘optlmize-primltlves*  (optimize-binary-order  op  argl  arg2)))) 
(whan  ordar 

(satq  op  ordar) 

(psetq  argl  arg2  arg2  argl) ) 

(alloc-src-reg 

argl 

•  '(lambda  (arclloc) 

(a 1 1 oc-are-1 oc 
arg2 

•  '(lambda  (arc21oc) 

(alloc-dst-rag 
(stmt-target  a tat) 

• '  (lambda  (dstloc) 

(could-algrata) 

(force  argl) 

(forca  arg2) 

(gan-lnst  top  op  tarcl  arclloc  :arc2  arc21oc  tdat  datloc) 
(trash-rag  dstloc)))))) 

:forbldden  (If  (Icon at?  (bast-loc  (locations  arg2)t)  't(O)  bO)))) 

; ; ; Ganarata  tha  Instructions  for  tha  divide  and  remainder  atataaants. 

(dafun  gan-dlvlda-lnsts  (stmt  remainder?) 

(gan-raad-slot  (atmt-arg  stmt)  ragl  t) 

(gan-raad-slot  (stmt-arg2  stmt)  ragO) 

(gan-call  "Dlvlda”  traads  '#(0  1)  twrltes  *<(0  1() 

(lat  ((target  (stmt -target  stmt))) 

(gen-wrlte  (if  raaulnder?  ragl  ragO)  (tha-locatlon  target)  target))) 


,-;;Generate  the  conditional  instructions, 
(defun  gen- cond-1 nets  (stmt) 
(alloc-src-rag 
(atmt-arg  stmt) 

*• (lambda  (srcloc) 

(could-migrate) 

(forca  ( atmt-arg  stmt) ) 

(gan-lnst  :op  (stmt-method  stmt)  : 


srcl  srcloc 


:src2 


'*.(make-loc  Tel))))) 


;;; Generate  coda  to  forca  slot  by  reading  It  Into  a  raglstar. 

;;;Do  not  usa  one  of  the  forbidden  registers. 

(defun  gan-force  (slot  skay  (forbidden  bO) ) 

(If  (unforced  slot) 

(gen-read  (tha-locatlon  slot)  slot  (alloc-reg  : forbidden  forbidden)))) 


;;;Ganerate  code  to  touch  a  variable, 
(defun  gen-touch-lnsts  (stmt) 
(gen-force  (atmt-arg  stmt))) 


;;; Generate  code  to  create  a  nee  object. 

(defun  gen-new-lnsta  (stmt) 

(gen-force  (stmt-target  stmt))  .-Avoid  putting  target  into  limbo. 

(gen-read-speclal  (make-sconst  (+  (class-nlvars  (stmt-method  stmt))  f lrst-lnstance-slot-num) )  regl) 
(gen-read-speclal  (make-1 const  'class  (stmt -method  stmt))  regO) 

(gen-call  *Bew_Object”  treads  '*(0  1)  twrltes  '0(0  11) 

(could-migrate) 

(let  ((target  (stmt -target  stmt))) 

(gen-wrlte  regO  (the- location  target)  target))) 


;; .-Generate  the  value  return  code. 

(defun  gen- reply- Inst s  (stmt) 

(let*  ( (arg  (atmt-arg  stmt)) 

(tempreg  (alloc-reg  :forbidden  '#(0))) 

(forbidden-map  (bset  0  (bset  (reg-num  tempreg))))) 

(If  (and  (lvar?  arg)  (migratep) ) 

(gen-read  (the-locatlon  arg)  arg  (alloc-reg  :forbldden  forbidden-map)) 

(gen- force  arg  : forbidden  forbidden-map)) 

(If  ‘reply-node* 

(progn 

(gen-read-speclal  (reply-slot)  tempreg) 

(let*  ((branch  (gen-inat  :op  'bnil  :srcl  tempreg  :src2  ’•.(make-loc  ’rel))) 
(frame  (current-frame))) 

(gen-read-speclal  'I .  (make-lconst  tMSG  ' (’ReplyConst*  .  1))  regO) 
(gen-inst  :op  'send2  :srcl  (reply-node)  :arc2  regO) 

(gen-lnst  :op  'send2  :srcl  (reply-ID)  :src2  tempreg) 

(al loc-arc-loc 
arg 

•'(lambda  (srcloc)  (gen-lnst  :op  ' sende  :srcl  srcloc))) 
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{»erge-f  rame  frame) 

(gen -merge  branch) ) ) 

(progn 

(gen-read-special  (reply-ID)  tempreg) 

(let*  ( (node r eg  (alloc-reg  : forbidden  (bset  (reg-nura  tempreg)  '#(0}))) 

(branch  (gen-inat  :op  *bnil  :*rcl  tempreg  :*rc2  *#.(make-loc  Tel))) 
(frame  (current-frame) ) ) 

(gen- read- special  *#. (aake-1 const  tMSG  ' ("ReplyConst ■  .  4>)  regO) 
(gen-inst  sop  'wtag  :srcl  tempreg  :src2  (make-sconst  tINT)  :dst  nodereg) 
(gen-1 nst  sop  Tsh  ssrcl  nodereg  :src2  (make-sconst  -16)  sdst  nodereg) 
(gen-inst  sop  *send2  ssrcl  nodereg  ssrc2  regO) 

(gen-lnst  sop  'send  ssrcl  tempreg) 

(gen-inst  sop  'send  ssrcl  (reply-slot)) 

(alloc-src-loc 

arg 

•* (lambda  (srcloc)  (gen-inst  sop  'sende  ssrcl  srcloc))) 

(merge- frame  frame) 

(gen-merge  branch) ) ) ) ) ) 


;;;Generate  the  code  to  begin  execution. 

(defun  gen-enter-insts  (stmt) 

(declare  (Ignore  stmt)) 

(when  (get-nvlocs) 

(gen-read-special  (make-sconst  (get-nvlocs))  regO) 
(gen-call  "New_Context •  s reads  * # 1 0 )  s writes  *«(0  1))) 
(gen-lnst  sop  *init-vloca  swrites  *#(0}) 

(when  (ivara-used?) 

(gen-read  selfloc  *#. (make-slot  'self)  regO) 

(gen-inst  sop  'xlate 
ssrcl  regO 

ssrc2  »#. (make-sconst  tINT  "XLATE_OBJ") 
sdst  inatance-a-reg) 

(could-not -migrate) ) ) 


;;;Generate  the  code  to  terminate  execution. 

(defun  gen-exit-insts  (stmt) 

(declare  (ignore  stmt)) 

(when  (get-nvlocs) 

(let  ( (forced-locs  bO) ) 

(dollst  (Blot  (unforced-slots) ) 

(let  ( (loc  (the-locatlon  slot))) 

(unless  (btest  (loc-num  loc)  forced-locs) 
(bsetf  forced-locs  (loc-num  loc)) 
(gen-force  slot))))) 

(gen-call  "FreeContexf  swrites  *#(0  1))) 
(gen-inst  sop  'suspend) 

(gen-break) ) 


;; /Generate  code  to  do  a  csend  or  a  rsend. 

(defun  gen-send-insts  (stmt) 

(labels 

( ( force- 1 nst ob}  (args  tempreg) 

(cond 

( (endp  args)  nil) 

( (ivar?  (car  args) ) 

(gen-read  (the-locatlon  (car  args))  (car  aigs)  tempreg)) 

(t  (force-lnstobj  (cdr  args)  tempreg))))) 

(gen-force  (stmt -target  stmt))  ;Avoid  putting  target  into  limbo. 

(let  ((receiver  (If  (stmt -method  stmt)  (stmt -arg  stmt)  (stmt-arg2  stmt)))) 

(dollst  (arg  (reverse  (stmt-args  stmt))) 

(unless  (equal  arg  receiver) 

(gen-force  arg)))  ;Force  all  arguments  except  the  receiver. 

(if  (and  *optlmize-send-self*  (self?  receiver)  (get-ni vars) ) 

(progn 

(if  (migratep) 

fforce-instobj  (stmt-args  stmt)  regl})  /Force  instance  object  if  necessary, 
(gen-read-special  '#.(make-loc  ' sreg  *nnr)  regl)) 

(progn 

(gen-read-slot  receiver  regO) 

(if  (migratep) 

(force-instobj  (stmt-args  stmt)  regl))  ; Force  instance  object  if  necessary, 
(gen-call  "SendNodeNr"  : reads  '#(0)  :writes  *#{0  1))))) 

(gen-read-special 

(make-lconst  tMSG  (cons  "SendConst"  4 

(if  (stmt -method  stmt)  1  0) 

(length  (stmt-args  stmt))))) 

regO) 
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(gan-lnst  :op  • send  2  :srcl  regl  :src2  regO) 

(whan  (stat-aethod  stat) 

(gen-read-special  (aake-lconst  ‘set  hod  (stmt-aethod  stat})  regO) 
(gan-lnst  :op  ‘sand  :srcl  ragO) ) 

(dollst  (arg  (stat-args  stat)) 

(alloc- src-loc 
arg 

fdaabda  (argloc) 

(gan-lnst  :op  ‘sand  :srcl  argloc)))) 

(cond 

( (ag  (stat-oparatlon  stat)  ’rsand) 

(gan-lnst  :op  ‘sand  :srcl  (raply-ID)) 

(If  *raply-noda* 

(progn 

(gan-lnst  :op  ‘sand  :srcl  (reply-slot)) 

(gan-lnst  :op  ‘sands  :srcl  (raply-noda) ) ) 

(gan-lnst  : op  ‘sands  :srcl  (reply-slot)))) 

((nail  (stat-targst  stat)) 

(gan-lnst  :op  ‘sand  :srcl  • I.  (aake-loc  ‘sconst  wNIL)) 

(If  ‘raply-noda*  (gan-lnst  :op  ‘ssnd  :srcl  ‘I. (aake-loc  ‘sconst  wNIL))) 
(gan-lnst  :op  ‘sands  :srcl  •*. (aake-loc  ‘sconst  wNIL))) 

(t 

(lat  ((dstloc  (the- location  (stat -target  stat)))) 

(gan-lnst  :op  ‘sand  :srcl  contaxtID) 

(assart  (vloc?  dstloc)) 

(If  ‘raply-noda* 

(progn 

(gen-read-spaclal  ■#. (aake-loc  ‘srag  ‘nnrt  regl) 

(gan-lnst  :op  ‘send2a 

:srcl  (make-sconst  (loc-num  dstloc) ) 

:src2  ragl) ) 

(gan-lnst  :op  ‘sends  :srcl  (aake-sconst  (loc-nua  dstloc)))) 

(gan-lnst  :op  ‘wtag  :srcl  regl  :src2  (aake-sconst  tCFUT)  :dst  regl) 
(gen-wrlta  ragl  dstloc  (stat-targat  stat)) 

(trash- rag  ragl) 

(unforca  (stat-targat  stmt))))))) 
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;;;;l  Insert  branch  Instructions  Into  the  nodule  I 
Si  IS* - ♦ 

;;;Ravorso  the  condition  of  the  branch  Inst. 

(defun  reverse-condition  (nodule  Inst) 

(setf  (lnst-op  Inst)  (opposite-condition  (lnst-op  Inst))) 

(setf  (Inst-successors  Inst)  (reverse  (lnst-successors  Inst))) 
(altered-nodule  nodule)) 


;;;Insert  branch  Instructions  Into  the  nodule.  Return  the  nodule. 

(defun  Insert -branches  (nodule) 

(do  ((next  (Inst -next  (nodule-next  nodule))  (lnst-naxt  next)) 

(lnat  (lnat-next  nodule)  next)) 

((module?  Inst)  nodule) 

(labels 

( (Insert -branch  (successor) 

(Insert -nodule  nodule 

(new-lnst  :op  *br  :src2  ' ». (make-loc  ’rel)  :llve  (lnst-live  Inst)) 
Inst  successor! ) ) 

(let  ((successors  (dlnode-successors  Inst))) 

(cond 

((null  successors)) 

((null  (edr  successors)) 

(unless  (eq  (first  successors)  next) 

(Insert-branch  (first  successors) ) ) ) 

( (eq  (first  successors)  next)) 

( (eq  (second  successors)  next) 

(reverse-condition  nodule  Inst)) 

(t  (Insert-branch  (first  successors)))))))) 


; ; ,-  + - + 

;;;|  Calculate  live  data.  I 
?  ? ;+ - ♦ 

.-.•Calculate  the  live  registers  for  each  Instruction  In  the  module. 

(defun  calc-llve-regs  (module) 

(attribute 

'live  (digraph-attributes  (module-digraph  module)) 

(macro-relax  (module-digraph  module) 

♦'lnst-llve 

•'(lambda  (Inst  new-live)  (setf  (lnst-llve  Inst)  new-live)) 
•  '  (lambda  (Inst) 

(b+  (lnst-reads  Inst) 

(b-  (lnst-llve  Inst) 

(lnst-wrltes  Inst)))) 

:from-end  t) ) ) 


.-Calculate  the  live  variables  for  each  Instruction  In  the  module, 
(defun  calc-llve-vlocs  (module) 

(attribute 
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‘vlive  (digraph-attributes  (nodule-digraph  module) ) 

(macro-relax  (nodule-digraph  nodule) 

••inat-vllve 

••(lambda  (lnet  new-vllve)  (aetf  (inat-vllve  inat)  new-vlive)) 
•' (lambda  (Inst) 

(let  ((vlive  (lnat-vllve  lnat))) 

(If  (vloc?  (lnat-dst  lnat)) 

(bclrf  vlive  (loc-nun  (lnat-dst  lnat)))) 

(If  (vloc?  (lnst-srcl  lnat) ) 

(baetf  vlive  (loc-nun  (lnat-srcl  lnat)))) 

(If  (vloc?  (Inst-src2  lnat)) 

(baetf  vlive  (loc-niaa  (lnat-arc?  lnat)))) 
vlive) ) 

:fron-end  t )  > ) 


it  Initialize  variables  where  necessary.  | 


(defun  lnlt-vlocs  (nodule) 

(calc-1 lve-vlocs  module) 

(do  ((Inst  (nodule-next  module)  (lnst-next  Inst))) 

((nodule?  Inst)  (error  *Can‘t  find  IMIT-VLOCS*) ) 

(when  (eq  (Inst -op  Inst)  ‘lnlt-vlocs) 

(let  ((vlive  (b-  (lnat -vlive  Inst)  ••.(brange  first-context -slot-num) ) ) 
(next  (lnst-next  Inst))) 

(If  (bempty  vlive) 

(delete-nodule  sndule  Inst) 

(progn 

(setf  (Inst -op  Inst)  ‘novel 

(setf  (lnst-srcl  Inst)  • • . (make-loc  ‘sconat  wNIL)) 

(setf  (lnst-dst  Inst)  regO) 

(loop  for  locnun  being  the  bits  of  vlive  do 
(Insert -nodule  nodule 

(new-inst  :op  ‘move 
:srcl  regO 

:dst  (nake-loc  ‘vloc  locnun)) 
(lnst-prev  next) 
next))))) 

(return)))) 


; ; ; ;  ♦ - — — - — — — - - 

till  I  Test  whether  two  Instructions  ccnnute.  | 

- - - - ♦ - - - - 

« ; ; Return  true  If  the  two  Instructions  lnstl  and  lnst2  could  be  transposed  without  changing 
;;; the  meaning  of  the  program. 

;;;##MThls  routine  la  not  perfect — It  does  not  catch  acne  of  the  dependencies  Involving 
;;;speclal  registers,  but  It  does  work  In  the  simple  cases  in  which  it  is  called. #••• 

(defun  insts-coanute?  (lnstl  lnst2) 

(flet  ((same?  (vail  val2>  (and  vail  (equal  vail  val2)>)) 

(let  ( (opl  (lnst-op  lnstl)) 

(op2  (lnst-op  lnst2))) 

(not  (or  (branch?  opl) 

(branch?  op2) 

(eq  opl  ‘suspend) 

(eq  opl  ‘res) 

(eq  op2  ’suspend) 

(eq  op2  ' res ) 

(not  (bempty  (b*  (b+  (lnst-reads  lnstl)  (Inst-reads  inst2)> 

(b+  (Inst -writes  lnstl)  (Inst -writes  inst2))))) 

(same?  (lnat-srcl  lnstl)  (lnat-dst  inst2>) 

(same?  (Inst-src2  lnstl)  (lnst-dst  lnst2)l 
(same?  (lnst-srcl  lnst2)  (lnst-dst  lnstl)) 

(same?  (Inst-src2  lnst2)  (lnst-dst  lnstl)) 

(same;  (lnst-dst  lnstl)  (lnst-dst  inst2)) 

(areq?  (lnst-dst  lnstl)) 

(areg?  (lnst-dst  lnst2)) 

(sreg?  (lnst-dst  lnstl)) 

(sreg?  (lnst-dst  lnst2)) 

(and  (send-op?  opl)  (send-op?  op2) ) 

(and  (stack-op?  opl)  (stack-op?  op2)) 

(and  (assoc-op?  opl)  (assoc-op?  op2> )))))> 


a  ;* — - - - 

; ; ; I  Calculate  the  pc  values  and  compact  DC's.  | 
;;;+ — - - * 


; ; Return  the  last  Instruction  before  Inst  In  the  same  basic  block  as  Inst  that 
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///satisfies  test.  Return  NIL  if  there  Is  no  such  Instruction. 

(defun  prev-inst-that  (inst  test) 

(do  ((i  (lnst-prev  Inst)  (inst-prev  1)) 

(lest  Inst  1) ) 

((not  (ln-same-baslc-block?  i  last))) 

(if  (funcall  test  1)  (return  1 ) ) ) ) 

; ; .'Compact  SEND's  into  S£ND2‘s. 

(defun  ccapact -sends  (nodule) 

(do  ((next-inst  (lnst-next  (nodule-next  module))  (inst-next  next-lnst)) 

(inst  (nodule-next  nodule)  next-lnst)) 

((nodule?  inst)) 

(if  (or  (eq  (lnst-op  inst)  ’send)  (eq  (inst-op  inst)  'sende)) 

(if  (req?  (inst-srcl  inst)) 

(let  ((prev-lnst  (prev-inst-that  inst  •‘(lambda  (inst)  (send-op?  (lnst-op  inst)))))) 

(if  (and  prev-inst  (eq  (lnst-op  prev-inst)  'send)) 

(let  ( (new-prev-inst  (prev-inst-that  inst  #‘ (lambda  (1)  (not  (lnsts-commute?  i  inst)))))) 
(when  (do  ((i  prev-inst  (lnst-next  1))) 

((eq  1  new-prev-inst)  t) 

(unless  (lnsts-commute?  prev-inst  (lnst-next  1)) 

(return  nil))) 

(delete-module  module  inst) 

(unless  (eq  prev-inst  new-prev-inst) 

(delete-module  module  prev-inst) 

(Insert -nodule  module  prev-inst  new-prev-inst  (lnst-next  new-prev-inst))) 

(setf  (lnst-src2  prev-inst)  (lnst-srcl  inst)) 

(setf  (lnst-reads  prev-inst)  (b+  (inst-reads  prev-inst)  (lnst-reads  Inst))) 

(setf  (inst-op  prev-inst)  (if  (eq  (lnst-op  inst)  ‘send)  ‘send2  ■ send2e) )))))))) ) 


;;;Return  pc  aligned  to  the  next  word  boundary. 

(defun  align  (pc) 

(if  (oddp  pc)  (1+  pc)  pc)) 

/.'/Assign  PC  values  while  compacting  DCs. 

(defun  compact -asslgn-pcs  (module  optimize-dc) 

(labels 

( (asalgn-pcs-sub  (inst  pc) 

(cond 

( (module?  inst) ) 

( (evenp  pc) 

(setf  (lnst-pc  inst)  pc) 

(asslgn-pcs-sub  (lnst-next  inst)  (+  pc  (if  (eq  (lnst-op  inst)  'dc>  2  1)))) 
((not  (and  (one-elt-p  (inst -predecessors  inst!) 

(eq  (lnst-prev  inst)  (car  (lnst-predecessors  inst))))) 
(asslgn-pcs-sub  inst  (1+  pc))) 

( (eq  (inst-op  inst)  *dc) 

(let  ((prev-inst  (inst-prev  Inst)) 

(next-inst  (lnst-next  inst))) 

(cond 

((and  optlmlze-dc 

(ln-same-baslc-block?  prev-inst  inst) 

(lnsts-commute?  prev-inst  inst)) 

(swap-module  module  prev-inst  inst) 

(asslgn-pcs-sub  inst  (lnst-pc  prev-inst))) 

((and  optlmlze-dc 

(ln-same-basic-block?  Inst  next-lnst) 

(lnsts-commute?  inst  next-inst)) 

(swap-module  module  inst  next-lnst) 

(asslgn-pcs-sub  next-lnst  pc)) 

(t 

(setf  (lnst-pc  Inst)  (1+  pc)) 

(asslgn-pcs-sub  next-inst  (+  pc  3)))))) 

(t 

(setf  (lnst-pc  Inst)  pc) 

(asslgn-pcs-sub  (inst-next  Inst)  (1+  pc) ) )  ] ) ) 

(attribute 

•pc  (digraph-attributes  (module-digraph  module)) 

(asslgn-pcs-sub  (module-next  module)  0)))) 


///Return  the  length  of  the  module  In  words, 
(defun  module-length  (module) 
(compact-assign-pcs  module  nil) 

(let  ((last-lnst  (module-prev  module))) 

(If  (module?  last-lnst)  0 

(1+  (lnst-addr  last-lnst))))) 
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Expand  branch**  Into  long  branch**.  | 


/ ; ; Rat urn  tha  branch  distance  from  th*  fro*  ln*t  to  th*  to  lnat. 

;;;Return  nil  If  It  cannot  b*  determined. 

(defun  branch-distance  (Iron  to) 

(and  (ln*t-pc  froa) 

(lnst-pc  to) 

(-  (lnat-addr  to)  (1+  (ln«t-addr  from))))) 

;;; Return  trua  if  a  branch  from  tha  from  lnat  would  reach  the  to  lnat. 

(defun  branch-reache*;  (froa  to) 

;;B*  optlmlatlc  and  aaauae  that  If  either  pc  la  nil,  the  branch  would  reach, 
(let  ((dlatance  (branch-d lata nee  froa  to))) 

(or  (null  dlatanca) 

(<-  (Integer-length  dlatance)  4)))) 


;;;Convert  ahort  branche*  that  do  not  reach  their  destination*  Into  long  branche*. 
(defun  expand-branchea  (module) 

(labels 

( (non-regO-condltlonal?  (Inst) 

(and  (not  (btest  0  (lnat- live  lnat))) 

(or  (not  (equal  (lnst-srcl  lnat)  regO)) 

(let  ((prev  (lnst-prev  lnat)) 

(unused-reg-num  (blow  (bnot  (lnat-live  lnat))  1))) 

(if  (and  (<  unused-reg-num  3) 

(in-sama-baslc-block?  prev  lnat) 

(equal  (lnat-dst  prav)  regO)) 

(lat  ( (unuaad-rag  (aake-loc  ‘reg  unused-reg-num))) 

(setf  (lnat-dst  prav)  unuaad-rag) 

(bclrf  (inat-wrltaa  prav)  0) 

(bsetf  (inat-wrltaa  prev)  unusad-reg-num) 

(setf  (lnst-srcl  lnat)  unused-reg) 

(setf  (lnat-raads  lnat)  (bset  unused-reg-num) ) 
t)))))> 

(can-change-to-shorter-branch?  (Inst) 

(let  ((minimum-distance  15) 
mlnlmal-dest) 

(do  11  at  (pred  (Inst -predecessors  (branch-dast  lnat))) 

(If  (and  (not  (eq  pred  lnat)) 

(eq  (lnst-op  pied)  'br) 

(or  (relative?  (Inst-src2  pred)) 

(lat  ( (prad2  ( lnat -prav  pred) ) ) 

(and  (ln-same-baalc-block?  pred?  pred) 

(equal  (lnst-src2  pred)  'regO) 

(eq  (lnat -op  pred2>  ’dc) 

(setq  pred  pred2) ) ) ) ) 

(let  ((distance  (branch-distance  lnat  pred))) 

(whan  distance 

(If  (<  distance  0)  (setq  distance  (-  1  distance))) 

(when  (<  distance  minimum-distance) 

(setq  minimum-distance  dlatance) 

(setq  mlnlmal-dest  pred)))))) 

(when  mlnlmal-dest 

( unlink -dlnode  Inst  (branch-dest  Inst)) 

(llnk-dlnode  lnat  mlnlmal-dest) 

(altered-module  module) 
til) 

(expand-sub  (Inst) 

(cond 

((module?  Inst)) 

((or  (not  (branch?  (lnst-op  Inst))) 

(not  (relative?  (Inst-src2  Inst))) 

(branch-reaches?  lnat  (branch-dest  Inst))) 

(expand-sub  (lnst-next  Inst))) 

( (can-change-to-shorter-branch?  Inst) 

(expand-aub  (lnst-next  Inst))) 

( (eq  (lnst-op  Inst)  ’br) 

(slmple-expand-branch  Inst) ) 

((and  (ln-same-baalc-block?  Inst  (lnst-next  Inst)) 

(eq  (lnst-op  (lnst-next  Inst))  ’br) 

(branch-reaches?  Inst  (branch-dest  (lnst-next  Inst)))) 

(let*  ((next  (lnst-next  Inst)) 

(destl  (branch-dest  Inst)) 

<dest2  (branch-dest  next))) 

(unllnk-dinode  Inst  destl) 

(unllnk-dlnode  next  dest2> 


Appendix  D 


Complete  Listing  of  the  Compiler  Assembly  Code  Generator 


{reverse-condition  module  inst) 

(1 ink-dinode  inst  dest2) 

(link-dinode  next  destl) 

(altered-raodule  module) 

(expand-sub  next))) 

( (non-regO-conditional?  inst) 

(aimple-expand-branch  inst)) 

(t 

(reverse-condition  module  inst) 

(insert-module  module 

(new-inst  :op  'br  :src2  • # . (make-loc  *rel)  :llve  (inst-live  inst)) 
inst  (first  (inst-successors  inst))) 

(expand-sub  (inst-next  inst))})) 

(simple-expand-branch  (inst) 

(if  (btest  0  (inst-live  inst)) 

(error  "Attempt  to  create  a  long  branch  with  RO  live.")) 

(insert-before-raodule  module 

(new-inst  :op  *dc 

:srcl  (make-loc  'rel) 
iwrites  '#{0} 

:live  (bset  0  (inst-live  inst))) 

inst) 

(set f  (inst-src2  inst)  regO) 

(bsetf  (inst -reads  inst)  0) 

(altered-module  module))) 

(compact -a ssign-pcs  module  nil) 

(calc-live-regs  module) 

(expand-sub  (module-next  module) ) ) ) 


?  ; ;  ♦ - + 

;;;)  Perform  final  transformations.  I 

; ; ;  + - + 

(defun  inst-transformations  (module) 
(insert-branches  module) 

(init-vlocs  module) 

(if  *compact-sends*  (compact-sends  module)) 
(attribute-steady-state 
(digraph-attributes  (module-digraph  module) ) 
(progn 

(compact-assign-pcs  module  *opt imize-dc*) 
(expand-branches  module) ) ) ) 


; ; ; ;  + - ♦ 

;;;;|  Miscellaneous  printing  functions  | 

?;?;+ - + 

?; /Return  true  if  the  thing  is  a  name. 

(defun  name?  (thing) 

(or  (symbolp  thing)  (stringp  thing))) 

;; Return  a  string  containing  the  mapping  of  the  character. 

(defun  map-char  (char) 

(cond 

( (alpha numericp  char)  (string  char)) 

( (cadr  (assoc  char 

• ((#\_ 

(f \ !  "EXCLAMATION") 

(#\$  "DOLLAR") 

(#\%  "PERCENT") 

(#\*  "AMPERSAND") 

(#\«.  "PLUS") 

(#\-  "_•) 

(#\*  "TIMES") 

(#\/  "DIVIDE") 

(#\.  "DOT") 

(#\<  "LT") 

(#\>  -GT") 

(#\-  "EQUAL") 

(•\?  "QUESTION") 

(#\0  "AT") 

(#\~  "NOT") 

(«\\  "BACKSLASH") ) ) ) ) ) ) 

;; /Generate  a  string  representing  the  name  of  the  Identifier. 

;;?The  name  can  be  either  a  string  or  a  symbol;  If  It  is  a  string.  It  is  passed  through  unaltered, 
(defun  make-identifier  (name) 

(if  (stringp  name) 
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name 

(apply  f 'concatenate 

(cons  'simple-string 

(nap  'list  • 'map-char  (string  name)))))) 

Generate  a  string  representing  the  nane  of  the  method  and  class. 

;;  method-name  Is  a  symbol  or  a  string  containing  the  method  name. 

;;  class-name  Is  a  symbol  a  string  containing  the  class  name. 

(defun  make-module-identifler  (method-name  class-name) 

(If  class-name 

(concatenate  'simple- string  (make-ldentlfler  class-name)  “ _ ■  (make-ldentlfler  method-name)) 

(make-ldentlfler  method-name))) 


;;;Prlnt  Integer  tag  between  0  and  15  as  a  tag 
(defun  print-tag  (tag  stream) 

(format  stream  "- [SYM-; INT-;BOOL-?ADDR-;IP-;MSG-;CFUT-: "  tag)) 

;;;Print  the  word. 

(defun  print-word  (word  stream) 

(If  (name?  word) 

(wrlte-strlng  (make-ldentlfler  word)  stream) 

(let  ((a  (assoc  word  '(.(list  (list  wNIL  "NIL") 

(list  w FALSE  "FALSE") 

(list  wTRUE  "TRUE")) 

:tesL  * 'equal))) 

(cond 

(a  (wrlte-strlng  (cadr  a)  stream)) 

((find  (tag  word)  '(symbol  method  class)) 

(format  stream  "(-I(-A-)  -A)"  (tag  word)  (make- identifier  (data  word)))) 

(t 

(cond 

((name?  (tag  word))  (format  stream  "-A:"  (make-ldentlfler  (tag  word)))) 

((/-  (tag  word)  tlMT) 

(print-tag  (tag  word)  stream) 

(wrlte-char  #\:  stream))) 

(cond 

((name?  (data  word))  (wrlte-strlng  (make-identifier  (data  word))  stream)) 

( (consp  (data  word) ) 

(format  stream  "-A+-D*  (make-ldentlfler  (car  (data  word)))  (cdr  (data  word)))) 
((eql  (tag  word)  t INT)  (format  stream  "-D*  (data  word))) 

(t  (format  stream  "$-8,'0X"  (data  word))))))))) 


;;;;+ - + 

;;;;l  Print  the  module  I 
;;;;+ - + 

;;;Asslgn  labels  to  all  Instructions  that  are  destinations  of  branches. 

(defun  assign-labels  (module) 

(let  ((label  0)) 

(all-lnsts 

module 

»' (lambda  (Inst) 

(setf  (lnst-label  Inst) 

(unless  (and  (one-elt-p  (lnst-predecessors  Inst)) 

(or  (module?  (lnst-prev  Inst)) 

(eq  (lnst-prev  Inst)  (car  (lnst-predecessors  Inst))))) 
(lncf  label))))))) 

;;; Print  the  label. 

(defun  print-label  (num  stream) 

(format  stream  "L-3,*0D"  num)) 

;;;Prlnt  an  addressing  mode. 

(defun  print-loc  (loc  Inst  stream) 

(case  (loctype  loc) 

( (sconst  lconst)  (print -word  (loc-num  loc)  stream)) 

(reg  (format  stream  "R-D*  (reg-num  loc))) 

(areg  (format  stream  "A-D*  (loc-num  loc))) 

(sreg  (prlnl  (loc-num  loc)  stream)) 

(vloc  (format  stream  "(-D,A1|"  (loc-num  loc))) 

(Hoc  (format  stream  "(-D,A2)"  (loc-num  loc))) 

(aloe  (format  stream  "(-D,A3|"  (loc-num  loc))) 

(rel  (If  (branch?  (Inst -op  Inst)) 

(progn 

(wrlte-char  l\A  stream) 

(print-label  (lnst-label  (branch-dest  Inst))  stream)) 

(do  ((1  (lnst-next  Inst)  (lnst-next  1))) 

((and  (branch?  (Inst -op  1))  (reg?  (Inst-src2  1))) 

(print-label  (lnst-label  (branch-dest  1))  stream) 
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{format  stream  *-<*+~D)"  (-  (1+  (inst-addr  1} )  (lnst-addr  Inst))))))) 
(t  (error  "Bad  location  -S  in  -S*  loc  Inst)))) 

;; /Print  the  instruction. 

(defun  fomat-lnst  (inst  stream) 

(when  (lnst-label  inst) 

(print-label  (lnst-label  inst)  stream) 

(write-char  »\:  stream)) 

(format  stream  [~A-;-*-8T~l (-A-) *  "print -pc*  #\Tab  (inst-op  inst)) 

(let  ((separator  fVTab)) 

(labels 

( (print-arg  (arg) 

(when  arg 

(if  (and  *print-pc*  (eql  separator  «\Tab) ) 

(format  stream  "-16T") 

(write-char  separator  stream) ) 

(print-loc  arg  inst  stream) 

(setq  separator  #\,)))) 

(print -arg  (inst-srcl  inst)) 

(if  (eq  (inst-op  inst)  *xlate) 

(progn 

(prlnt-arg  (inst-dst  inst)) 

(print -arg  (lnst-src2  inst))) 

(progn 

(prlnt-arg  (inst-src2  inst)) 

(print -arg  (inst-dst  inst)))) 

(if  (and  "print -pc*  (inst-pc  inst)) 

(format  stream  *-<0T/-3D-: (-; . 5-1 "  (lnst-addr  inst)  (oddp  (inst-pc  inst)))) 
(terprl  stream)))) 


; /Print  a  listing  of  the  module  onto  the  stream. 

//  method-name  is  a  symbol  or  a  string  containing  the  method  name. 

//  class-name  Is  a  symbol  a  string  containing  the  class  name. 

(defun  format-module  (module  (optional  (stream  t)  (key  method-name  class-name) 

(flet  ((prlnt-dc  ()  (format  stream  "-ADC-A"  #\Tab  #\Tab| ) ) 

(assign-labels  module) 

(fresh-line  stream) 

(format  stream  "MODULE  -A-%"  (make-module-identifier  method-name  class-name) ) 
(prlnt-dc) 

(print -word  (make-word  tMSG  (cons  "LoadCode"  (+  3  (module-length  module))))  stream) 
(terprl  stream) 

(prlnt-dc) 

(print -word  (make-word  ‘class  class-name)  stream) 

(write-char  l\,  stream) 

(print -word  (make-word  ‘method  method-name)  stream) 

(terprl  stream) 

(all-insts 

module 

•'(lambda  (inst)  (format-lnst  Inst  stream))) 

(format  stream  *-AEND~%-%"  «\Tab))) 
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Mod*:  LISP;  Bass:  10.;  Syntax:  Common- 1 i sp;  Package:  USER  -*- 


CST  compiler 

Bill  Dally  S-Dec-87 

Last  revised  12-Jan-8S 

revised  Andrew  Chlen  2/88  (various) 

Naldemar  Korwat  4/88  (see  below) 


Done: 

1.  Add  parallel  message  sending 

2.  Add  output  to  shell 

3.  Profiling 

3.1.  Check  number  of  args  on  method  Invocation 

3.2.  Fix  arg  count  In  messages  by  flattening 

3.3.  Add  distributed  object  creation 
3.4  Add  distributed  object  addressing 
3.6  Add  constituent  addressing 

6.  Symbol  and  array  primitive  types 

11.  Modification  of  new  to  accept  parameters 

12a.  Addition  of  a  send  primitive 

13.  Trace  functions  added 

14.  Default  send  mode  Is  unsequenced.  SETs  necessary  to  sequentialire 
12b.  Fix  send  to  compile  to  csend  where  appropriate 

16.  Context  tracing  added 

Adapted  by  Maldemar  Horwat  as  front  end  for  CST  compiler  4/88 
— Fixed  two  bugs  that  would  cause  emission  of  Illegal  MOVE  Instructions 
— Removed  remains  of  blocks  and  Irrelevant  code 
— Split  ‘constants*  from  ‘global** 

— Changed  all  nonessentlal  sets  into  csets 
— Changed  all  sends  into  csend/touch  combinations 
— Removed  wait  parameters 

— Removed  SEND  keyword  and  adopted  scheme-like  syntax  Instead 
— Adapted  scheme-like  syntax  for  methods 


(defvar  ‘classes*  ' ()  ‘Class  Structure  and  methods*) 
(defvar  ‘globals*  • ()  ‘Globals  and  values*) 

(defvar  ‘constants*  • ()  'Constants  and  values*) 


Compiler  front-end  globals  for  compiling  blocks 


(defvar  ‘code*)  I 

(defvar  ‘args*)  efl 

(defvar  *vars‘)  | 

(defvar  ‘lvars*l  1 

(defvar  ‘temp*)  | 

(defvar  ‘label ‘I  1 


Front  end  for  cat  compiler 


(defun  cst-error  (string  (rest  args) 

(apply  ♦'format  ‘standard-output*  string  args) 
nil) 

(defun  display-array  (value) 

(let  { (y  nil) ) 

(dotlmes  (x  (length  value))  (setq  y  (cons  (aref  value  x)  y) ) ) 
(format  ‘standard-output*  *  -S*  (reverse  y) ) ) ) 


code  relating  to  classes 


;;  (class  name  ( Iparent-classes) )  (Instance-variables)) 

(defun  compile-class  (form  output-stream) 

(let  ((class  (expand-class  (cdr  form)))) 

(setq  ‘classes*  (cons  class  ‘classes*)) 

(If  output-stream  (make-accessor-methods  class  output-stream)) 
class) ) 


(defun  expand-class  (class) 

(let  ((supers  (class-supers  class))) 
(list  (class-name  class) 
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Front  End 


supers 

(append  (get -super- vars  supers) 

(eddr  class) ) 

nil  ;  placeholders  for  methods  and  dlst 

(If  (llstp  supers)  (member  'distobj  (get -superclass-1 1st  • ()  supers)))))) 
;  true  if  distributed  object 

(defun  get -superclass-list  (accumulated  active) 

(let  ((new-acc  (append  active  accumulated)) 

(new-active  (loop  for  class-name  In  active  appending 

(class-supers  (get -class  class-name) ) ) ) ) 

(setf  new-active  (delete  '  ()  new-active)) 

(if  (null  new-active)  new-acc 

(get-superclass-llst  new-acc  new-active)))) 


«  •  *  ——————————  —  _ 

(defun  get-super-vars  (supers) 

(if  (and  supers  (llstp  supers)  (not  (eq  (car  supers)  'object)) 

(not  (eq  (car  supers)  'dlst))) 

(append  (instance-vara  (car  supers)) 

(get-super-vars  (edr  supers))))) 

(defun  instance-vara  (class-name) 

(class-vars  (get-class  class-name) ) ) 

■  • 

(defun  raake-accessor-methods  (class  output -stream) 

(let  ( (lvars  (class-vars  class)) 

(class-name  (class-name  class) ) ) 

(dollst  (v  lvars) 

(compile-method  (Method  , class-name  ,v  ()  ()  (return  ,v))  output-stream)))) 

e  •  •  _  — —  —  ~  *-  —————— 

(defun  get-class  (class-name) 

(let  ((class  (assoc  class-name  'classes*))) 

(if  class 
class 

(cat -error  “-(Undefined  Class  -S“  class-name)))) 

(defun  class-name  (class)  (car  class) ) 

(defun  class-supers  (class)  (cadr  class) ) 

(defun  class-vars  (class)  (caddr  class)) 

; (defun  class-methods  (class)  (cadddr  class) ) 

(defun  class-dlst  (class)  (fifth  class!) 

•  •  •  — ————  — 

IS  (method  class  method-name  ((args))  ((temps))  (statements)) 

(defun  compile-method  (form  (optional  (output-stream  t) ) 

(If  (<  (length  form)  C) 

(cat -error  “-(Method  missing  field  -S“  form) 

(let  ((class-name  (second  form)) 

(method-name  (third  form) ) 

(args  (fourth  form)) 

(vars  (fifth  form) ) 

(body  (nthedr  S  form) ) ) 

(let  ( (icode  (compile-block  args  vars  (instance-vars  class-name)  body))) 

(If  output-stream 

(complle-lcode  method-name  class-name  (length  args)  icode  :output-stream  output-stream)) 
Icode)))) 


t  i  S  —————— —————————————————— ——  ——————————  ———  —  —  ————————  — 

(defun  compile-block  (args  vars  lvars  body) 

;; (format  “standard-output*  “-(compile-block  -S  -S  -S  -S*  args  vars  lvars  body) 
(let  ((‘code*  nil) (*args*  args) (*vars*  vars)  (“lvars*  lvars) (‘temp*  0) (‘label*  0) ) 
(compile-statements  body) 

(reverse  *code*))) 


(defun  compile-statements  (body) 

(If  (>  (length  body)  1) 

(progn  (compile-statement  (car  body))  (compl le-statements  (edr  body))) 
(compile-statement  ' (return-*  .(car  body))))) 

*  t 

?;  Top  level  expressions  don't  require  replies 

(defun  compile-statement  (stat) 

(compile-expression  '()  stat)) 


(defun  symbol- Is -keyword?  (expr) 

(find  expr 

(if  ‘anachronisms* 

'(set  cset  reply  reply-x  forward  exit  iftrue  if  begin 
new  newco  quote  send  msg  touch) 

'(set  cset  return  return-x  reply  reply-x  exit  iftrue  if  begin 
new  newco  quote  msg  touch) ) ) ) 

(defun  symbol-type  (expr) 
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(cond  ( (nunberp  expr)  ' (const  ,  axpr) > 

((not  (symbolp  upr) )  nil) 

((aq  axpr  ‘self)  ’self) 

( (aq  axpr  1 supar)  ■ supar) 

( (aq  axpr  • group)  • group) 

( psember  axpr  *vars*)  (vsr  ,  (lndax  axpr  *vars*d) 

( (aaabar  axpr  *args*)  ‘ (arg  ,  (lndax  axpr  *args*))) 

( (iwhir  axpr  *lvars*>  *  (ivsr  ,  (lndax  axpr  *lvars*))) 

( (synbol-is-keyword?  axpr)  'keyword) 

((assoc  axpr  *globals*)  '(global  ,expr>) 

((assoc  axpr  ‘constants*)  '(const  ,  (cdr  (assoc  axpr  ‘constants*)))) 
(t  (list  'method  expr) )) ) 

(defun  coapile-atoa  (slot  axpr) 

(let  ((type  (symbol -type  axpr))) 

(If  type 

(check-binding  slot  type) 

(cst-arror  *-tbad  atonic  axprassion  -S*  axpr)))) 


//  compiles  an  expression  and  puts  the  result  In  slot 
//  If  slot  Is  nil,  doesn't  put  the  result  anywhere. 

;;  If  slot  is  ' _unbound_  creates  a  temporary 
(dafun  conpila-axprassion  (slot  axpr) 

; (format  ‘standard-output*  "-scampi la-expression  -S  -S*  slot  expr) 

(If  (atom  expr) 

(complle-ato*  slot  expr) 

(let  ((head  (car  expr))) 

(If  (eq  (symbol-type  head)  'keyword) 

(ecase  head 

((sat  cset)  (coapi la-set  slot  expr)) 

((return  return-x)  (compile- return  head  slot  expr)) 

(reply 

(If  ‘anachronisms*  (compile-return  'return  slot  expr) 
(compile-reply  'reply  slot  axpr))) 

(reply-x 

(If  ‘anachronisms*  (compile-return  'return-x  slot  expr) 
(compile-reply  'reply-x  slot  expr))) 

(forward  /anachronism 

(If  (aq  (cadr  axpr)  'requester) 

(coeplle- reply  ‘reply-x  slot  (list  'reply-x  (cddr  expr))) 
(cst-arror  "~*Can't  reply  to  -S*  (cadr-expr) ) ) ) 

(exit  (emit  '(exit))  slot) 

(lft rua  (camplla-iftrue  slot  expr)) 

(If  (complle-lf  slot  expr)) 

(begin  (compile- begin  slot  expr) ) 

(naw  (compile-new  slot  axpr)) 

(new co  (complle-newco  slot  expr) ) 

(quote  (check-binding  slot  '(const  ,  (cadr  expr)))) 

(msg  (compile-message  slot  expr) ) 

(send  /anachronism 

(coeplle- express Ion  slot  (cdr  axpr))) 

(touch  (compile-touch  slot  axpr))) 

(compile- sand  slot  axpr) ) ) ) I 


(defun  conplle-begln  (slot  expr)  (complle-begln-1  slot  (cdr  axpr))) 

(defun  coaplle-begln-1  (slot  expr) 

(If  (>  (length  expr)  1) 

(progn  (compile-statament  (car  expr))  (conpile-begln-1  slot  (cdr  expr))) 
(compile-expression  slot  (car  expr) ) ) ) 

//  (new  class-name) 

//  (new  class-nama  inlt-parameter) 

(defun  coaplle-new  (slot  expr) 

(let*  ((tl  (check -bound  slot)) 

(class-nama  (cadr  expr) ) ) 

(If  (-  2  (length  expr}) 

(emit  '(new  ,tl  ,  class-name) ) 

(emit  '(new  ,tl  , class-nama  , (compile-atom  *_unbound_  (third  expr))))) 
tl) ) 


(defun  lookup-wrlteable-id  (name) 

(lat  ((obj  (ccmpl le-atom  *_unbound_  name))) 

(if  (and  (llatp  obj)  (member  (car  obj)  '(war  ivar  global))) 
obj 

(cst-error  "-tcan't  set  Identifier  -S"  name)))) 


///  special  for  to  make  a  constituent  of  a  distributed  object 

//  (newco  node-number  newlndex  DO-slie  root)  ;/  only  used  by  distobj  def 

(defun  complle-newco  (slot  expr) 

(if  (check-length  5  expr) 


J 


a 
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(let*  ((tl  (check-bound  (lot)) 

(ergs  (aapcar  I'dawbda  (x)  (compile-cxpression  •_unbound_  x) )  (cdr  expr) ) ) ) 
(emit  (newco  ,tl  .large)) 
tl))) 


;;  (eat  slot  value-expresaion) 
tl  (caet  alot  value-expreaaion) 

(defun  complle-set  (alot  expr) 

(It  (check-length  3  expr) 

(let*  ((daat  (lookup-wrlteable-ld  (cadrexpr))) 
(type  (car  expr)) 

(wait  (eq  type  'eat))) 

(compl le-expreaeion  daat  (caddr  expr)) 

(If  wait  (aalt  4 (touch  ,deet))) 

(check-binding  alot  daat)))) 


;;  (reply  value-expreaaion) 

;;  (reply-x  value-expreaaion) 

(defun  compl le-reply  (head  alot  expr) 

(If  (check-length  2  expr) 

(let  ( (reault  (ccaipile-expreaslon  '_unbound_  (cadr  expr)))) 
(ealt  '(.head  .reault)) 

(check-binding  alot  reault)))) 


;;  (return  value-expreaaion) 

;;  (retum-x  value-expreaaion) 

(defun  compile-return  (head  alot  expr) 

(If  (check-length  2  expr) 

(let  ((reault  (coeipile-expresslon  ‘_unbound_  (cadr  expr)))) 

(ealt  '(.head  .reault)) 

(check-binding  alot  result)))) 

•  e  •  —  —  .  .  4~~  1 

;;  (selector  dest  (args)) 

(defun  complle-send  (alot  expr) 

(let  ((selector  (coaplle-expresaion  '_unbound_  (first  expr))) 

(dest  (check-bound  alot) ) 

(args  (mapcar  ••(lambda  (x)  (compile-expression  '_unbound_  x) )  (cdr  expr)))) 
(If  (eq  (car  selector)  ‘const) 

(cst-error  ■-tcan,t  send  to  -S*  (first  expr))) 

(emit  ' (csend  .dest  .selector  .(args)) 
dest) ) 


;;  (msg  node*  selector  dest  (args))  not  Implemented 
(defun  coapi le-message  (slot  expr) 

(let  ( (arqs  (mapcar  »• (lambda  (x)  (compile-expression  '_unbound_  x) )  (cdr  expr)))) 
(emit  ' (mag  .(args)) 
slot)) 


;;  (iftrue  cond-expresslon  true-block  false-block) 

(defun  compl le-1 ft rue  (alot  expr) 

(if  (<  (length  expr)  3) 

(cst-error  ■-ssyntax  error  -S*  expr) 

(let*  ((11  (new-label) ) 

(tl  (compile-expression  '_unbound_  (cadr  expr))) 

(t2  (check-bound  slot)) 

(cl  (compile-expression  *_unbound_  (caddr  expr))) 
(c2  (if  (>  (length  expr)  3) 

(compile-expression  *_unbound_  (cadddr  expr)) 
nil))) 

(emit  4  (false jump  ,tl  ,11)) 

(emit  4 (csend  ,t2  value  ,cl)) 

(if  c2 

(let  ((12  (new-label) )) 

(emit  4  (]ump  , 12) ) 

(emit  4 (label  ,11) ) 

(emit  4 (csend  ,t2  value  ,c2)) 

(emit  4  (label  ,  12) ) ) 

(emit  4 (label  ,11) )) 

1 2 ) ) ) 


ll  (if  condition-expression  true-arm  false-arm) 

(defun  complle-if  (slot  expr) 

(if  (<  (length  expr)  3) 

(cst-error  “-tsyntax  error  -S*  expr) 

(let*  ((11  (new-label)) 

(tl  (compile-expression  '_unbound_  (cadr  expr))) 

(t2  (check-bound  slot)))  ~ 

(If  (and  (-  (length  expr)  3)  t2)  (emit  4  (move  ,t2  (const  nil)))) 
(emit  4  (falsejump  ,tl  ,11)) 

(compile-expression  t2  (caddr  expr)) 

(if  (>  (length  expr)  3) 


Front  End 
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(let  <  (12  (new-label) ) ) 

(emit  •  (]ump  ,12 )) 

(salt  (label  ,11)) 

(compile-expression  t2  (cadddr  expr) ) 

(malt  '  (label  ,12)1) 

(emit  '  (label  ,11))) 
t2)>) 

Si  f  ———  ■  _________  _  _  _  ___  ______ 

SI  (touch  variable) 

(defun  compile-touch  (slot  expr) 

(when  (check- length  2  expr) 

(If  (null  slot)  (setq  slot  *_unbound_)) 

(let  ((dest  (check-binding  slot  (compile-expression  slot  (second  expr))))) 
(emit  '(touch  ,dest)) 
dest))) 

•  • 

(defun  check-length  (n  expr) 

(if  (/-  (length  expr)  n) 

(cst-error  ‘-ssyntax  error  -S*  expr) 
t)  > 

(defun  check-bound  (a)  (if  (eq  a  '  unbound  )  (new-temp)  a)) 


;;;  if  a  is  already  bound  move  b  to  a  and  return  a  otherwise  return  b 
(defun  check-binding  (a  b) 

(if  (eq  a  ‘unbound! 
b 

(if  (equal  a  b) 
a 

(progn  (if  a  (emit  '(move  ,a  ,b))> 
a)))) 

(defun  new-label  () 

(let  ((result  ‘label*)) 

(setq  ‘label*  (♦  ‘label*  1)) 
result) ) 

(defun  new-temp  () 

(let  ((result  (temp  ,*te»p*))) 

(setq  *temp‘  (+  ‘temp*  1) ) 
result) ) 

•  #  ‘  —  <*l~ 

(defun  emit  (code) 

(setq  *code‘  (cons  code  ‘code*)) 

;  (format  ‘standard-output*  *-«emlt  -S‘  code) 

) 

f  t  J— —————————————  —  —  ——  ———————————————————— —— 

{defun  index  (a  1)  (indexl  a  1  0) ) 

(defun  Indexl  (a  1  n) 

(If  1  (if  (eq  a  (car  1))  n  (Indexl  a  (edr  1)  (♦  1  n))))> 

*  *  S  ———————————— — — 

(defun  compile-global  (form) 

(push  (cons  (cadr  form)  (caddr  form))  ‘globals*)) 

ft!  —  —  —  —  —  —  —  —  —  —  —  —  ——  —  —————————————————  —  —  —  —  —————  ———————  —  —  —  —  ————  —  —————  — 

(defun  compile- const ant  (form) 

(push  (cons  (cadr  form)  (caddr  form))  ‘constants*}) 
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It; Set  to  enable  CST  anachronisms. 

(defparameter  ‘anachronisms*  nil) 

t;; Set  to  display  the  names  of  methods  as  they  are  being  compiled, 
(defparameter  *verbose-cst *  t) 


»»»»+ - + 

Parameters  I 

mi* - ♦ 

;; ; Optimization  settings: 

; Remove  assignments  to  variables  that  will  not  be  used  again. 

(defparameter  *delete-dead-defs*  t) 

;Try  to  remove  unnecessary  HOVE  statements. 

(defparameter  *delete-moves*  t) 

;Try  to  remove  unnecessary  TOUCH  statements. 

(defparameter  *delete-touches*  t) 

/Calculate  dataflow  Information  and  use  It  to  perform  a  variety  of  optimizations  such 
/as  changing  x:-y-0,  branch  If  x  false  sequences  to  BNE  Instructions. 

(defparameter  *df low-optimizations*  t) 

/Fold  constants.  For  example,  replace  1+2  by  3.  Also  remove  conditional  branches  when 
/It  can  be  determined  that  the  condition  Is  always  true  or  always  false. 

(defparameter  ‘fold-constants*  t) 

/Enable  the  altering  of  CSENDs  Immediately  followed  by  RETURNS  into  RSENDs  which  allow 
/the  process  to  be  deallocated  and  the  answer  directly  forwarded  to  the  caller.  This 
/is  the  equivalent  of  tall  recursion. 

(defparameter  *forward-sends*  t) 

/Merge  common  pieces  of  code  wherever  possible. 

(defparasieter  *merge-code*  t) 

/Perform  local  primitive  optimizations  such  as  changing  multiplications  to  shifts. 

(defparameter  ‘optlmlze-prlmltives*  t) 

/Accumulate  Information  about  which  variables  are  forced  and  optimize  forces  when  the  variables 
/are  known  to  be  forced. 

(defparameter  *optlralze-forces*  t) 

/Compact  variables  in  the  context  to  use  as  few  slots  as  possible. 

(defparameter  *optlmlze-vars*  t) 

/Assign  variables  to  registers  whenever  possible. 

(defparameter  *req-varlables*  t) 

/Use  the  lru  algorithm  to  allocate  temporary  registers  during  code  generation. 
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(defparaiaater  *use-lru-reglster-allocat Ion*  t) 

;Keep  track  of  varlablei  In  the  remitters  during  code  generation  and  use  values  from  the 
; registers  instead  of  from  aeaory  whenever  possible. 

(defparaaeter  *opt lmi is- local -regs*  t) 

;Keep  track  of  whether  It  Is  possible  for  the  Instance  object  to  have  migrated  away. 
;Don‘t  force  It  If  It  could  not  have  migrated  away. 

(defparaaeter  *optlmize-migrate*  t) 

,-Don't  XIATE  the  Instance  object  if  there  are  no  references  to  it. 

(defparaaeter  *optlmize-lvar-access  *  t) 

,‘Don't  allocate  a  context  unless  it  is  actually  used. 

(defparaaeter  *opt lalie-nul 1-contexts*  t) 

; Send  message  to  the  current  node  if  the  receiver  Is  SELF  and  it  Is  not  atomic. 

(def parameter  *optimize-send-self •  t) 

;Try  to  combine  SENDS  and  SENDEs  into  SEHD2s  and  SEND2ES. 

(defparaaeter  ‘compact-sends*  t) 

;Try  to  align  DC's  on  word  boundaries  whenever  possible. 

(defparaaeter  *opt lai ze-dc*  t) 


;Use  an  additional  reply  node  field  in  SENDS, 
(defconstant  “reply-node*  nil) 

,'Print  program  counter  values  as  connects  in  output, 
(defparameter  *print-pc*  t) 

;;;Set  all  optialzatlons  to  value. 

(defun  all-optimizations  (value) 

(setq  *delete-dead-defs*  value) 

(setq  *delete-moves*  value) 

(setq  'delete-touches*  value) 

(setq  *dflow-optlmlzatlons*  value) 

(setq  ‘fold-constants*  value) 

(setq  ‘forward-sends*  value) 

(setq  *merge-code*  value) 

(setq  * opt lml ze-prlmitives*  value) 

(setq  *optlmlze-forces*  value) 

(setq  *optlmlze-vars*  value) 

(setq  *reg-varlables*  value) 

(setq  *use-lru-register-allocatlon*  value) 

(setq  *optlmlze-local-regs*  value) 

(setq  *optlmlze-mlgrate*  value) 

(setq  *optlmlze-lvar-access*  value) 

(setq  *optlmlze-nul 1-contexts*  value) 

(setq  *optimize-send-self *  value) 

(setq  ‘compact-sends*  value) 

(setq  *optlmize-dc*  value)) 


;;;;+ - + 

;;;; I  Debugging  parameters  I 
;;;;+ - + 

;;;Warning:  Do  not  change  this  setting  without  recompiling  all  files! 

;Use  debugging  data  structures,  which  results  in  easier  debugging  but  a  slower  compiler, 
(defvar  “debug*  t) 


#+llapm  (Import  • si : loop-tassoc) 

l+:Maclntosh  (set -mac-default-directory  “HDrlve:MDP:Compller:") 
(load  *011111108*) 

(load  -HOrd*) 

(load  *Stmt*) 

(load  *Inst*) 

(load  "GenStmt*) 

(load  “Genlnst”) 

(load  "GenAsm") 

;;; Compile  the  icode  for  the  method  and  output  It  on  the  stream. 
;;;  nargs  is  the  number  of  arguments  for  the  method. 

/•;;  method  is  a  symbol  or  a  string  containing  the  method  name. 
;;;  class  Is  the  class. 

;;;  stream  Is  the  stream  onto  which  the  output  Is  to  be  printed. 
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(defun  complle-lcode  (method  class  nargs  lcode  (key  (output-stream  t)) 

(whan  *varbosa-cst  * 

(format  t  "-tfComplllng  and  optimizing  1-Coda  for  Mthod  -S  class  method)) 

(1st  ( (stmtgraph  (opt lal ie-stat graph  (lnput-lcoda  lcode)))) 

(whan  *verbose-cst  * 

(foraat  t  *-t;Coapiling  to  asse ably  language  method  -5  -S. .  .-»*  class  method)) 
(lat  ((module  (coapl la-statgraph  stmtgraph  nargs  (class-nlvars  class)))) 
(lnst-transformatlons  module) 

(format-module  module  output -stream 
: method-name  method 
: class-name  class)))) 

((/Compile  the  lcode  and  output  the  resulting  stmtgraph. 

;;;Thls  function  is  for  debugging  purposes  only. 

(defun  optlalza-icode  (lcode) 

(optlalxe-stmtgraph  (lnput-lcoda  lcode))) 


(load  "Front*) 


(defconstant  atomic-classes  ‘(Integer  Symbol  Boolean  Float)) 

((/Return  the  number  of  Instance  variables  the  class  has  or  nil  if  the  class  is  atomic, 
(defun  class-nlvars  (class) 

(unless  (find  class  atomic-classes) 

(length  (lnstance-vars  class)))) 


;  ;/;* - ♦ 

;;;; I  compiler  l 
; ; ; ;  + - + 

;;;Compile  the  method  and  output  the  optimised  lcode  and  the  number  of  variables  used. 
;;;This  function  Is  for  debugging  purposes  only. 

(defun  optlmlze-method  (form) 

(optlmlze-lcode  (compile-method  form  nil))) 


;;;Complle  the  form  to  the  output-stream. 

(defun  complle-form  (form  ^optional  (output-stream  t)) 

(when  * verbose-cat * 

(format  t  "~*(Compillng  ~S  -S~i[  -S-1...-R*  (car  form)  (cadr  form) 
(If  (eq  (car  form)  'method)  (caddr  form)))) 

(let  ((head  (car  form))) 

(case  head 

(class  (compile-class  form  output-stream)) 

(method  (compile-method  form  output-stream) | 

(global  (compile-global  form)) 

(constant  (compile-constant  form)) 

(load  (complle-from-flle  (cadr  form)  output-stream)) 

(t  (error  “Bad  form:  -S"  form) ) ) ) ) 

;; (Compile  the  forms  to  the  output-stream. 

(defun  compile-forms  (forms  (optional  (output-stream  t)) 

(dollst  (form  forms) 

(complle-form  form  output-stream))) 

;; (Compile  from  the  file  named  ln-file-name  to  the  output-stream, 
(defun  complle-from-flle  (ln-file-name  (optional  (output-stream  t)) 
(wlth-open-flle  (ln-flle  ln-flle-name  (direction  : Input) 

(do  ((*  (read  ln-flle  nil  ’exit)  (read  ln-flle  nil  'exit))) 
l  (eq  x  ’exit)) 

(complle-form  x  output -stream) )) ) 

;; (Initialize  the  cst  classes,  globals,  and  constants. 

(defun  init-cst  () 

(setq  "classes*  nil) 

(setq  'globals*  nil) 

(setq  ‘constants*  nil) 

(compile-forms  '((Class  Object  (I) 

(Class  Integer  (Object)) 

(Class  Float  (Object) ) 

(Class  Symbol  (Object)) 

(Class  Boolean  (Object)) 

(Class  Array  (Object)  1  a) 

(Constant  nil  nil) 

(Constant  t  true) 

(Constant  true  true) 

(Constant  false  false))  nil)) 

(inlt-cst) 


Compiler 


i 


135 


A  Concurrent  Smalltalk  Compiler  for  the  Message-Driven  Processor 


;;;Coaplle  from  the  file  named  ln-flle-name  to  the  file 
(defun  cst  (ln-f 1 le-name  out-flle-name) 

(lnlt-cst) 

(with-open-flle  (out-flle  out-flle-name  :dlrectlon  :lo 
(complle-froei-flle  ln-flle-name  out-flle))) 


named  out-flle-name. 


:lf-exlsts  -.supersede) 
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Appendix  E.  Using  the  Compiler 

In  order  to  use  the  compiler,  first  load  the  LOOP  macro  and  install  it  with  (use-package  'loop) 
unless  it  was  already  installed.  Then  load  the  Compiler. lisp  or  a  compiled  Compiler  file,  which 
should  automatically  load  all  other  compiler  files.  At  this  point  the  compiler  can  be  used 
interactively  or  to  compile  entire  files.  The  available  calls  are  as  follows: 

Compiling  Files:  | 


•  (cst  input-file-name  output-file-name)  will  compile  the  file  named  input-file-name  and 
write  the  compiled  methods  to  a  new  file  named  output-file-name.  Progress  information  and 
errors,  if  any,  are  printed  to  the  terminal. 

Interactive  Compilation: 

•  (init-CSt)  erases  the  compiler's  knowledge  of  previous  user-defined  classes.  It  is 
automatically  called  by  the  cst  function. 

•  (compile-forms  forms-list  output-file-stream)  compiles  the  Concurrent  Smalltalk  forms 
given  as  a  list  in  forms-list  and  writes  the  resulting  code  onto  output-file-stream.  If  output-file- 
stream  is  omitted,  the  code  is  written  to  the  terminal.  This  method  does  not  call  init-CSt, 
thereby  allowing  interactive  compilation. 

•  (compile-form  form  output-file-stream)  compiles  the  single  Concurrent  Smalltalk  form 
given  as  a  list  in  form  and  writes  the  resulting  code  onto  output-file-stream.  If  output-file- 
stream  is  omitted,  the  code  is  written  to  the  terminal;  if  it  is  nil,  no  code  is  generated.  If  the 
form  is  a  method  definition,  this  method  returns  the  I-Code  generated  by  the  Front  End  when 
compiling  the  form.  This  method  does  not  call  init-CSt,  thereby  allowing  interactive  com¬ 
pilation. 

•  (all-optimizations  state)  turns  all  Optimist  optimizations  that  can  be  disabled  off  (if 
State  is  nil)  or  on  otherwise. 
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